複数ブックを別のブックのひとつのシートにまとめたいです。

同じファルダ内にある複数のブック（依頼リスト）を日付と時間で抽出して、別のブックのひとつのシートにまとめたいです。

ブックは依頼者ごと（6つ）になっており、まとめたい情報はA列～G列、11行目からスタートです。
毎日更新され、1日に入力される依頼はいくつか不明です。
但し、依頼リストは全部で1人50個までしか入力できません。

A列　　B列　　C列　　E列～G列
№　　 日付 時間　 依頼内容等

ボタンをクリックすると、指定した期間（日付・時間）の6人の依頼をひとつのシートにまとめたいです。
例えば、11/14分（11/13の16：31～11/14の16：00まで）。
期間を指定するごとにシートが増えていくようにしたいです。

さらに指定で抽出されたら、元のデータ（6つのブック）のH列に「✔」をつけたいです。

マクロ初心者です。
色々調べて自分なりにやってみましたが、ひとつにまとまりません。

分かりにくい説明ですいません。
どなたか詳しい方がいらっしゃいましたら　教えてもらえないでしょうか。
よろしく　お願いいたします。

質問者からの補足コメント

• 分かりにくくてスイマセン。
  
  ブックの様式は下記のとおりです。
  
  このブック6つをB列とC列で抽出して（例：11/14　16：31～11/15　16：30等）別のブックのひとつのシートに貼りつけたいです。
  
  できれば抽出条件ごとにシートがまとめてシートが増えていくようにしたいです。
  
  それで、抽出したものはH列に「✔」がつくようにしたいです。（下記は例の抽出の場合）
  　　　
  　　　　　A列　　　B列　　　　C列　　D列～G列　　　H列
  10行目　　№　　 　日付 　 　　時間　 依頼内容等
  11行目　　山田1　　11/14　　 16：03　　　　　　
  12行目　　山田2　　11/14　　 16：50　　　　　　　　　✔
  13行目　　山田3　　11/15　　 9：30　　　　　　　　　 ✔
  14行目　　山田4　　11/15　　 13：25　　　　　　　　　✔

    補足日時：2018/11/14 16:44

No.5 ベストアンサー 回答者： tom04 回答日時： 2018/11/20 11:48

続けてお邪魔します。

＞やはりグルグルするだけで
＞完了BOXも出なくなってしまいました。

結局ファイル形式は「xlsx」で良いようなので、一番最初に帰ってみてはどうでしょうか？

お手元のVBE画面のコードをすべて消去し、
もう一度No.2のコードをそのままコピー＆ペーストしてマクロを実行してみてください。

※　最初の段階ではメッセージボックスだけは表示された！というコトなので
何らかの結果が出るかもしれません。

当然のコトですが、
＞myPath = ThisWorkbook.Path & "\"
としているので、
コード記載のブックは他の6つのブックと同じフォルダ内に保存している！という前提です。
（コード記載のブックを保存していない場合は「パス」そのものが存在しません）

保存していない場合は
一旦コード記載のブックを同じフォルダに名前を付けて保存し、
再度開いてからマクロを実行してみてください。m(_ _)m

この回答へのお礼

お返事ありがとうございます。

＞もう一度No.2のコードをそのままコピー＆ペーストしてマクロを実行してみてください。

やってみましたがダメでした。。。。スイマセン

＞コード記載のブックは他の6つのブックと同じフォルダ内に保存している！という前提です。

同じフォルダに抽出条件にあった日付と時刻を入力して保存しましたがダメでした。。。

＞一旦コード記載のブックを同じフォルダに名前を付けて保存し、再度開いてからマクロを実行してみてください。m(_ _)m

貼り付け先のブックを保存して再度開いてからマクロを実行しましたがダメでした。。。


ホントにスイマセン。
せっかく作ってもらったのに。。。知識があれば　こちらの状態に修正して　すぐ活用できるのかもしれないのですが。

お礼日時：2018/11/20 15:42

No.4 回答者： tom04 回答日時： 2018/11/19 19:10

何度もごめんなさい。

No.2のお礼欄をよく読んでいませんでした。

＞バージョンが古いので「xlsx」→「xlsm」に変更してやってみたのですが。。

バージョンが古かったらExcel2003までの拡張子は「xls」ではありませんか？

「xlsm」はExcel2007以降のマクロ有効ブックのファイル形式になります。m(_ _)m

この回答へのお礼

こちらこそ丁寧にありがとうございます。

＞バージョンが古かったらExcel2003までの拡張子は「xls」ではありませんか？

プロパティで「xlsx」と表示されていたので。。。
さきほど「xlsx」→「xls＊」と変更してみたのですが、やはりグルグルするだけで
完了BOXも出なくなってしまいました。

引続き頑張ってみます。
ありがとうございました。

お礼日時：2018/11/20 11:36

No.3 回答者： tom04 回答日時： 2018/11/19 16:20

No.2です。

＞BOXで完了の知らせはあるのですが何も読み込んできません。

というコトは各ブックのSheet1のH列にもチェックは入っていないのですね。

エラーは出ていないというコトなので、コード自体は問題ないと思います。
ただ気になる点がいくつかあります。

①　各ブックのSheet1のB列はシリアル値になっているか？

②　
「今日」を基準にしていますので、
仮に前回のマクロを今日実行した場合
各ブックのSheet1のB列日付が
昨日の　16：30　より遅く、なおかつ本日の　16：30以前のデータがないと何も反応しません。

可能性としては②が怪しいような気がします。

※　日付を指定したい場合は
コード内の
＞DATE
が今日のシリアル値なので、その部分を変更してみてください。
（どこかのセルに対象日を入力し、そのセルを参照しても構いません）m(_ _)m

この回答へのお礼

お返事ありがとうございます。
さっき試してみたら、ずっとぐるぐるして完了BOXも出なくなってました・・・。

＞というコトは各ブックのSheet1のH列にもチェックは入っていないのですね。

チェックも入ってませんでした。

＞①　各ブックのSheet1のB列はシリアル値になっているか？

B列とC列はD列に入力があった場合に入力日付と時刻を返すようにしてます。
シリアル値ですが周りの人に聞いても分からなくって、セルの書式設定で日付になっておます。

＞②　「今日」を基準にしていますので、仮に前回のマクロを今日実行した場合各ブックのSheet1のB列日付が昨日の　16：30　より遅く、なおかつ本日の　16：30以前のデータがないと何も反応しません。

仮入力で前日から今日の16：30以前、以降のデータを入力して試してみましたがダメでした・・・。

スイマセン。
こちらの説明不足で申し訳ございません。
勉強しながら頑張って変更してみます。

お礼日時：2018/11/19 17:02

No.2 回答者： tom04 回答日時： 2018/11/18 00:36

こんばんは！

一例です。

①　６つのファイルの拡張子は「.xlsx」である。
②　コード記載のブック（This Workbook）と6つのファイルは同じフォルダに保存している。
③　6つのファイルの参照先シート名はすべて「Sheet1」である。
④　貼り付け先はThis WorkbookのSheet1である。

以上の前提条件でコードを考えてみました。

This Workbookの標準モジュールにしてください。

Sub Sample1()
　Dim myPath As String, fN As String
　Dim wB As Workbook, wS As Worksheet
　Dim i As Long
　　myPath = ThisWorkbook.Path & "\"
　　fN = Dir(myPath & "*.xlsx")
　　Application.ScreenUpdating = False
　　　Do Until fN = ""
　　　　If fN <> ThisWorkbook.Name Then
　　　　　Workbooks.Open myPath & fN
　　　　　　Set wB = ActiveWorkbook
　　　　　　Set wS = wB.Worksheets("Sheet1")
　　　　　　　For i = 11 To wS.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　　If wS.Cells(i, "B") + wS.Cells(i, "C") > Date - 1 + TimeSerial(16, 30, 0) And _
　　　　　　　　　wS.Cells(i, "B") + wS.Cells(i, "C") <= Date + TimeSerial(16, 30, 0) Then
　　　　　　　　　　wS.Cells(i, "A").Resize(, 7).Copy _
　　　　　　　　　　　ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　　　　　　　wS.Cells(i, "H") = ChrW(10003)
　　　　　　　　End If
　　　　　　　Next i
　　　　　　wB.Save
　　　　　　wB.Close
　　　　　　fN = Dir()
　　　　End If
　　　Loop
　　Application.ScreenUpdating = True
　　　MsgBox "完了"
End Sub

※　ブックを開くところからやっていますので、
少し時間を要するかもしれません。m(_ _)m

この回答へのお礼

回答どうもありがとうございます。

バージョンが古いので「xlsx」→「xlsm」に変更してやってみたのですが。。。

BOXで完了の知らせはあるのですが何も読み込んできません。
初心者なので　どこを変更したら良いのかわから状態です。

少しづつ勉強しながら変更してみようと思います。

お礼日時：2018/11/19 15:00

No.1 回答者： ぐーるぐる 回答日時： 2018/11/14 15:18

まずは、ベタでいいのでイメージを添付してもらえると助かります。