ここから本文です

フォルダ内の全てのエクセルファイル(サブフォルダ内を含む)の中から特定の日付...

num********さん

2018/1/1100:58:27

フォルダ内の全てのエクセルファイル(サブフォルダ内を含む)の中から特定の日付データ(例2018/2/1)をA列に持つエクセルファイルを全て開くというマクロを作成したいのですが、

ご教示いただけますでしょうか?

閲覧数:
204
回答数:
3
お礼:
500枚

違反報告

ベストアンサーに選ばれた回答

プロフィール画像

カテゴリマスター

hot********さん

2018/1/1112:41:30

最初に、日付の扱いがバージョンによって違うらしく、うまくFindで見つけられない場合があるかもしれません。
その場合はバージョンを教えてください。

それと見つけたbookは開いたままにするのでしょうか。
Excelは同名のファイルを同時に開くことができないので、既に開いているファイルと同名のファイルは開けないのでチェックができません。

Sub sample()
checkFolder "C:\test", "2018/2/1" '1フォルダチェック
End Sub

'1フォルダチェック
Sub checkFolder(folder As String, s As String)
Dim file As String
Dim wb As Workbook
Dim ws As Worksheet
Dim flg As Boolean
Dim rng As Range
If Right(folder, 1) <> "\" Then folder = folder & "\" 'フォルダの最後を"\"に(dir関数用)
'ファイルチェック
file = Dir(folder & "*.xls?") 'フォルダ内の最初のエクセルファイル名
Do While file <> "" 'ファイルがある間
Set wb = Nothing 'エラーに備えてNothingに
On Error Resume Next 'エラートラップ開始
Set wb = Workbooks.Open(folder & file) 'ブックを開く(既に開いているブックと同名のファイルは開けない)
On Error GoTo 0 'エラートラップ終了
If wb Is Nothing Then 'ブックが開けない場合
If MsgBox(folder & file & " が開けません" & vbCrLf & "続けますか?", vbYesNo) <> vbYes Then Exit Sub '続けるか聞く
Else 'ブックが開けた場合
flg = False 'A列に日付があったかのフラグ(初期値はFalse)
For Each ws In wb.Sheets 'ブックにのシートを順に
Set rng = ws.Range("A:A").Find(DateValue(s), LookIn:=xlFormulas, LookAt:=xlWhole) 'A列で日付を探す
If Not rng Is Nothing Then 'Nothingでなかったら(あったら)
flg = True '見つけたフラグをセット
Exit For '他を調べる必要が無いのでループを抜ける
End If
Next
If flg = False Then wb.Close False '日付が無かったら保存せずに閉じる(日付があったら閉じない)
End If
file = Dir '次のファイル名
Loop '繰り返す
'フォルダチェック
Dim fso As Object
Dim subFolder As Object
Set fso = CreateObject("Scripting.FileSystemObject") 'fso
For Each subFolder In fso.GetFolder(folder).subFolders 'サブフォルダを順に
checkFolder subFolder.Path, s '1フォルダチェック(再帰呼び出し)
Next
End Sub





ADOを使えばチェックは出来ると思うのですが、もし日付があっても同時には開けません。
という事で、見つけたファイル名をシートに記録する場合です。

Sub sample()
Cells.Clear '結果クリア
checkFolder "C:\test", "2018/2/1", 1 '1フォルダチェック(1は結果表示行の初期値)
End Sub

'1フォルダチェック
Sub checkFolder(folder As String, s As String, r As Long)
Dim file As String
Dim wb As Workbook
Dim ws As Worksheet
Dim flg As Boolean
Dim rng As Range
If Right(folder, 1) <> "\" Then folder = folder & "\" 'フォルダの最後を"\"に(dir関数用)
'ファイルチェック
file = Dir(folder & "*.xls?") 'フォルダ内の最初のエクセルファイル名
Do While file <> "" 'ファイルがある間
Set wb = Workbooks.Open(folder & file) 'ブックを開く
For Each ws In wb.Sheets 'ブックにのシートを順に
Set rng = ws.Range("A:A").Find(DateValue(s), LookIn:=xlFormulas, LookAt:=xlWhole) 'A列で日付を探す
If Not rng Is Nothing Then 'Nothingでなかったら(あったら)
flg = True '見つけたフラグをセット
Exit For '他を調べる必要が無いのでループを抜ける
End If
Next
wb.Close False '保存せずに閉じる
If flg = True Then
Range("A" & r).Value = folder & file '見つけたファイルを表示
r = r + 1 '表示行+1
End If
file = Dir '次のファイル名
Loop '繰り返す
'フォルダチェック
Dim fso As Object
Dim subFolder As Object
Set fso = CreateObject("Scripting.FileSystemObject") 'fso
For Each subFolder In fso.GetFolder(folder).subFolders 'サブフォルダを順に
checkFolder subFolder.Path, s, r '1フォルダチェック(再帰呼び出し)
Next
End Sub

  • 質問者

    num********さん

    2018/1/1501:02:35

    ご回答ありがとうございます。
    VBAにてVBScriptとどうように開く事が可能となりました。
    ご教示頂き誠にありがとうございます。

    上にも記載いたしましたが、
    もし可能でしたら、開かれた全てのエクセルファイルの必要項目を別のエクセルへ一覧としてまとめる事は可能でしょうか?
    例)2018/2/1がA20にあったとして


    A2:ファイル名
    B2:B20(2018/2/1の隣のセル)
    C2:D20
    D2:G20
    E2:H20
    ※A3へは次に見つかった2018/2/1の日付を持つファイルの同一項目の情報。

    宜しくお願い致します。

  • その他の返信を表示

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この質問は投票によってベストアンサーに選ばれました!

ベストアンサー以外の回答

1〜2件/2件中

並び替え:回答日時の
新しい順
|古い順

プロフィール画像

カテゴリマスター

lin********さん

2018/1/1114:15:18

申し訳ございません。

なぜか、「日付」だと、「VBA」では見つけてくれませんでしたが、全く同じやり方の「VBScript」なら、ちゃんと検索してくれました。

一応、「VBA」の方も掲載しておきますが、ファイルは次々開いているものの、開いたままになりませんでした(見つかりませんでした)。

「VBScript」の方は「ツール」としてお考えください(「Windows限定」です)。

以下のプログラムを、メモ帳かテキストエディタに貼り付け、「~.vbs」という名前で保存します。

「~」の部分は、何でもかまいませんが、「.vbs」の部分は、必ず半角です。

できたプログラムファイル(「~.vbs」ファイル)を、目的のフォルダ(たとえば、「ABC」フォルダ以下のフォルダ(「ABC」フォルダを含む)を調べたい場合「ABC」フォルダ)に放り込んで、ダブルクリック(「シングルクリック」→「Enter」の方が確実)するだけです。

すべての「xls」、「xlsx」、「xlsm」を開き、すべてのシートの列「A」から「2018/2/1」を検索し、見つかったブックは開いたままにし、見つからなかったブックは、閉じています。

Option Explicit
Public b(), c, e, ex, f, m, n, gf, s, so, x
Set so = CreateObject("Scripting.FileSystemObject")
Set gf = so.GetFolder(".")
Set ex = CreateObject("Excel.Application")
ex.Application.DisplayAlerts = False
ex.Visible = True
c = -1
Set m = so.GetFolder(gf)
Call y
Call z
Set gf = Nothing
Set so = Nothing
MsgBox("Finished!")

Sub y
For Each n in m.Files
e = LCase(so.GetExtensionName(n.Name))
If e = "xls" or e = "xlsx" or e = "xlsm" Then
c = c + 1
ReDim Preserve b(c)
Set b(c) = ex.Workbooks.Open(m & "\" & N.Name)
x = 0
For Each s In b(c).Worksheets
Set f = s.Range("A:A").Find("2018/2/1")
If Not (f is Nothing) = True Then
x = 1
Exit For
End If
Next
If x = 0 Then
b(c).Close
Set b(c) = Nothing
End If
End If
Next
End Sub

Sub z
For Each m In gf.SubFolders
Call y
Set gf = Nothing
Set gf = so.GetFolder(m)
Call z
Next
End Sub

簡単な説明です。

Set so = CreateObject("Scripting.FileSystemObject")

ファイルやフォルダを扱えるようにしています。

Set gf = so.GetFolder(".")

プログラムファイルの存在するフォルダを取得しています。

Set ex = CreateObject("Excel.Application")

エクセルを扱えるようにしています。

c = -1

カウント変数の初期化。

Set m = so.GetFolder(gf)

自分自身のフォルダを「m」にセット。

Call y

「y」サブプロシージャを呼び出しています。

Call z

「z」サブプロシージャを呼び出しています。

Set gf = Nothing
Set so = Nothing
MsgBox("Finished!")

終了処理の後、「Finished!」と表示しています。

Sub y

「y」サブプロシージャの始まり。

For Each n in m.Files

「m」フォルダ内のすべてのファイルを1つずつ処理。

e = LCase(so.GetExtensionName(n.Name))

見つかったファイルの拡張子を「e」に入れています。

If e = "xls" or e = "xlsx" or e = "xlsm" Then

もし、その拡張子が「xls」、「xlsx」、「xlsm」なら、

c = c + 1

1つカウント。

ReDim Preserve b(c)

配列変数の添え字を増やしています。

Set b(c) = ex.Workbooks.Open(m & "\" & N.Name)

そのブックを開いています。

x = 0

チェック用変数の初期化。

For Each s In b(c).Worksheets

今開いたブックのすべてのシートを1つずつ処理。

Set f = s.Range("A:A").Find("2018/2/1")

列「A」限定で、「2018/2/1」を検索。

If Not (f is Nothing) = True Then

見つかった場合は、

x = 1
Exit For
End If

「x」を「1」にして、「For ~ Next」を抜け出しています。

Next

を、すべてのシートで繰り返しています。

If x = 0 Then

ここまできて、「x = 0」なら、「見つからなかった」ので、

b(c).Close
Set b(c) = Nothing
End If

そのブックは閉じています。

End If
Next

を、フォルダ内のすべてのファイルで繰り返しています。

End Sub

「y」サブプロシージャの終わり。

Sub z

「z」サブプロシージャの始まり。

For Each m In gf.SubFolders

「m」フォルダ内のすべてのサブフォルダを処理。

Call y

「y」サブフォルダを呼び出しています。

Set gf = Nothing
Set gf = so.GetFolder(m)

見つかったサブフォルダを「gf」にセット。

Call z

自分自身である、「z」サブプロシージャを呼び出し、サブフォルダ内のサブフォルダを順次検索してゆきます。

Next

を、すべてサブフォルダで繰り返しています。

End Sub

「z」サブプロシージャの終わり。

では、「VBA」の方です。

マウスのカーソルを、「Sub Main()」内において、「F5」を押して、実行してください。

今は、マクロを走らせているブックのセル「A1」に、検索する「2018/2/1」が書き込まれているものとしています。

また、今は、私の環境である「D:\Programming」のままになっていますが、「Set gf = so.GetFolder("")」の部分を、質問者の環境に合わせてから、実行してください。

Public b() As Workbook, s As Worksheet
Public c As Integer, d As String, e As String
Public f As Object, m As Object, gf As Object
Public n As Object, so As Object, x As Integer
Sub Main()
d = ThisWorkbook.ActiveSheet.Range("A1").Text
Set so = CreateObject("Scripting.FileSystemObject")
Set gf = so.GetFolder("D:\Programming")
c = -1
Set m = so.GetFolder(gf)
Call y
Call z
Set gf = Nothing
Set so = Nothing
MsgBox ("Finished!")
End Sub

Sub y()
For Each n In m.Files
e = LCase(so.GetExtensionName(n.Name))
If e = "xls" Or e = "xlsx" Or e = "xlsm" Then
c = c + 1
ReDim Preserve b(c)
Set b(c) = Workbooks.Open(m & "\" & n.Name)
x = 0
For Each s In b(c).Worksheets
Set f = s.Range("A:A").Find(What:=d, LookIn:=xlValues)
If Not (f Is Nothing) = True Then
x = 1
Exit For
End If
Next
If x = 0 Then
b(c).Close
Set b(c) = Nothing
End If
End If
Next
End Sub

Sub z()
For Each m In gf.SubFolders
Call y
Set gf = Nothing
Set gf = so.GetFolder(m)
Call z
Next
End Sub

やっていることは、「VBScript」と全く同じなのですが、なぜか1つもひっかかりませんでした・・・

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

web********さん

2018/1/1110:30:54

VBAだとフォルダー内の全てのExcelファイルを順に開いて該当データの有無を調べていかなければなりません

サブフォルダーやファイル数によっては結構時間のかかる処理になります
エクスプローラーの検索で絞り込んでCtrl+Aで全選択して開く操作ではダメなんでしょうか?
(A列限定は出来ませんが)

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる