エクセル マクロ サブフォルダ内も同時に参照したい

Question

エクセル　マクロ　サブフォルダ内も同時に参照したい

見よう見まねで売上チェックのマクロを組みました。
年月を指定してマクロを走らせると指定されたフォルダ（fd_path）内の該当ＰＤＦ（MAQ-NC*）各ファイルから
金額を抽出してエクセルに表示し、表示した重複のＰＤＦファイルは削除して金額を合算します。

この指定フォルダ（fd_path）の下にもフォルダがいくつかあり、そちらも同時に読み込んで金額を抽出したい
のですがどうすればよろしいでしょうか。

Option Explicit

Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const GW_HWNDNEXT As Long = 2
Private Const TCM_SETCURFOCUS As Long = &H1330
Private Const WM_COMMAND As Long = &H111
Private Const AppPath As String = "C:\Program Files (x86)\Adobe\Reader 11.0\Reader\AcroRd32.exe" 'Adobe Readerのパス
Private hPage As Long

Public Sub 指定月毎売上自動一連()

  Dim reg1 As String
  Dim reg2 As String
  Dim reg3 As String
  Dim reg4 As String

  Dim dlg As FileDialog
  Dim fd_path As String  'フォルダのフルパス
  Dim fl_name As String  'ファイル名
  Dim i As Long  'ファイル名を出力する行番号
  Dim filename1 As Variant
  
  reg1 = Range("B4")
  reg2 = Range("B5")

'セルのクリア
  Range(reg1, reg2).ClearContents
  
  
'=====================PDFの特定行からテキスト抽出
'PDFからテキスト抽出


 reg3 = Range("U4")
 fd_path = Range("B1") & "\" & Range("U3") & "\" & Format(reg3, "00")


  'フォルダ内の一つ目のファイル名を取得
  fl_name = Dir(fd_path & "\MAQ-NC*")
  
  If fl_name = "" Then
    MsgBox fd_path & " にはファイルが存在しません。"
    Exit Sub
  End If

  'ファイル名を書き出し
  i = Range("B2")
  Do Until fl_name = ""
    Cells(i, 1).Value = fl_name
    i = i + 1
    '次のファイル名を取得
     fl_name = Dir
  Loop

  
  
  
Dim k As Long
Dim CMDLine As String       '実行するコマンドライン


reg4 = Range("B3")
For k = Range("B2") To Range(reg4).End(xlUp).Row
filename1 = Cells(k, 1).Value

    
 '実行するコマンドラインを作る
CMDLine = "CMD /c C:\xd2tx220\command\xdoc2txt.exe " & fd_path & "\" & filename1 & " > C:\xd2tx220\aaa\tmp.txt"
CreateObject("WScript.Shell").Run CMDLine
Debug.Print CMDLine

Application.Wait [Now() + "00:00:00.3"]

 'テキスト内の￥マーク行を出力してエクセルに書き出す
    Dim fso As Object, buf As String, buf2 As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    
  Open "C:\xd2tx220\aaa\tmp.txt" For Input As #1
    
  Dim Pos As Long
  Dim PriceStr As String
  
  Do Until EOF(1)
     Line Input #1, buf
     Pos = InStr(buf, "\")
    
    If Pos > 0 Then
      PriceStr = Mid(buf, Pos) '\マークが見つかった場所から文字を抽出
      buf2 = PriceStr
      Debug.Print buf2
      Else

    End If
  Loop
  Close #1

  Cells(k, 2).Value = buf2 'エクセルに書き出し
  Set fso = Nothing
Next




'重複データを削除し合計を合算
Dim myDic As Object
Dim myKey As Variant
Dim myItem As Variant
Dim myList As Variant
Dim i2 As Long

Dim reg11 As String
Dim reg13 As String
Dim reg14 As String

reg13 = Range("B8")
reg14 = Range("B9")

'セル（指定月）のクリア
Range(reg13, reg14).ClearContents

reg11 = Range("B6")

    
    Set myDic = CreateObject("Scripting.Dictionary")
    
    'C列,D列のデータを配列に格納
    myList = Range(reg11, Range("C" & Rows.Count). _
                     End(xlUp)).Resize(, 2).Value


    '連想配列にデータを格納
    For i2 = 1 To UBound(myList, 1)

        '店舗名が空欄かチェック
        If Not myList(i2, 1) = Empty Then
            If Not myDic.Exists(myList(i2, 1)) Then

                '重複しない店舗名を取得
                myDic.Add Key:=myList(i2, 1), Item:=myList(i2, 2)
            Else
                
                '売上金額を加算
                myDic(myList(i2, 1)) = myDic(myList(i2, 1)) + myList(i2, 2)
            End If
        End If
    Next

    myKey = myDic.Keys

    '[売上]   各店舗の合計を格納
    myItem = myDic.Items

    'リストを出力
    For i2 = 0 To UBound(myKey)
        Cells(i2 + Range("B2"), 7).Value = myKey(i2)
        Cells(i2 + Range("B2"), 10).Value = myItem(i2)
    Next

    '開放
    Set myDic = Nothing


End Sub


Public Function GetPDFPages(ByVal PdfPath As String) As Long
  Dim hApp As Long, hDlg As Long, hTab As Long, hPageNum As Long
  Dim cmd As String
  Dim winName As String
  Dim buf As String * 255
  Dim ret As Long
  Dim timeLimit As Date
 
  ret = 0& '初期化
  cmd = """" & AppPath & """" & " " & """" & PdfPath & """"
  'Shell cmd, vbNormalFocus 'Adobe Reader起動
  CreateObject("Shell.Application").ShellExecute """" & PdfPath & """" '関連付けされている場合はこちらでも可
  timeLimit = DateAdd("s", 5, Now()) 'ループの制限時間:5秒
  Do
    hApp = FindWindowEx(0&, 0&, "AcrobatSDIWindow", vbNullString)
    Sleep 500&
    DoEvents
    If Now() > timeLimit Then Exit Do '制限時間を過ぎたらループを抜ける
  Loop While hApp = 0&
  If hApp = 0& Then GoTo Err
  PostMessage hApp, WM_COMMAND, &H1788, 0& '文書のプロパティ表示
  timeLimit = DateAdd("s", 5, Now()) 'ループの制限時間:5秒
  Do
    hDlg = FindWindowEx(0&, 0&, "#32770", "文書のプロパティ")
    Sleep 500&
    DoEvents
    If Now() > timeLimit Then Exit Do '制限時間を過ぎたらループを抜ける
  Loop While hDlg = 0&
  If hDlg = 0& Then GoTo Err
  hTab = FindWindowEx(hDlg, 0&, "GroupBox", vbNullString)
  hTab = FindWindowEx(hTab, 0&, "SysTabControl32", vbNullString)
  If hTab = 0& Then GoTo Err
  SendMessage hTab, TCM_SETCURFOCUS, 0&, 0& '「概要」タブ選択
  EnumChildWindows hDlg, AddressOf EnumChildProc, 0&
  If hPage = 0& Then GoTo Err
  hPageNum = GetWindow(hPage, GW_HWNDNEXT)
  If hPageNum = 0& Then GoTo Err
  If GetWindowText(hPageNum, buf, Len(buf)) = 0& Then GoTo Err
  winName = Left$(buf, InStr(buf, vbNullChar) - 1)
  ret = CLng(winName)
  SendMessage hDlg, WM_COMMAND, vbOK, 0& 'ダイアログを閉じる
  SendMessage hApp, WM_COMMAND, &H1791, 0& 'アプリケーション終了
Err:
  GetPDFPages = ret
End Function

Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
  Dim clsName As String, winName As String
  Dim buf1 As String * 255, buf2 As String * 255
 
  If GetClassName(hWnd, buf1, Len(buf1)) <> 0& Then
    clsName = Left$(buf1, InStr(buf1, vbNullChar) - 1)
    If clsName = "Static" Then
      If GetWindowText(hWnd, buf2, Len(buf2)) <> 0& Then
        winName = Left$(buf2, InStr(buf2, vbNullChar) - 1)
        If winName = "ページ数 :" Then
          hPage = hWnd
          EnumChildProc = False
          Exit Function
        End If
      End If
    End If
  End If
  EnumChildProc = True
End Function

 

Comments

[meg_]

> この指定フォルダ（fd_path）の下にもフォルダがいくつかあり
対象のフォルダ(名)は固定なのですか？それともフォルダ(名)や数は動的なのですか？

[kensproject]

reg3 = Range("U4")
fd_path = Range("B1") & "\" & Range("U3") & "\" & Format(reg3, "00")

Range("B1") →　固定パス
Range("U3") →　2021　などの西暦（変動）
Range("U4") →　７　などの月（変動）

が入ります。
そして今回同時に読み取りたいその下のフォルダ名はどんなファイル名になるか
分からないので動的です。

[jinoji]

指定フォルダの下のフォルダの中に更にフォルダがあって、、、のようなことはありますか？

[kensproject]

指定フォルダの下は１階層のみとなります。２階層目はありません。
また指定フォルダの下(１階層)には6つ以内のフォルダが作られます。

指定フォルダ→任意名のフォルダ

Answer 1

Dirを使う代わりにこんな感じで考える手もありそうです。

 fd_path = Range("B1") & "\" & Range("U3") & "\" & Format(reg3, "00")
 i = Range("B2")
 
 Dim fl, subf
 With CreateObject("Scripting.FileSystemObject").GetFolder(fd_path)
    For Each fl In .Files
        If fl.Name Like "MAQ-NC*" Then
            Cells(i, 1).Value = fl.Name
            i = i + 1
        End If
    Next
    For Each subf In .SubFolders
        For Each fl In subf.Files
            If fl.Name Like "MAQ-NC*" Then
                Cells(i, 1).Value = subf.Name & "\" & fl.Name
                i = i + 1
            End If
        Next
    Next
 End With
 
  
 If i = Range("B2") Then
    MsgBox fd_path & " にはファイルが存在しません。"
    Exit Sub
 End If

Comments

[kensproject]

素人の私でも理解ができました。
無事動作致しました。とても！感謝したします！！！
ありがとうございました。

Answer 2

再帰関数を使ってファイル一覧を取得する感じがいいと思います。

再帰処理でフォルダー一覧を作成するサンプルマクロ

---

すみません追記見てなかった。みんなコメントしてるじゃん。
１階層なら再帰関数使わなくていいし！

---

(追記 2021/03/20)
再帰呼び出しまでしなくてよさそうなので、1階層したのファイルをログに出すだけの処理を記載します。

    Dim tFolder As String
    Dim tSubFolders() As String
    Dim tIndSubFolder As Long
    Dim tIndFile As Long
    
    ' サブフォルダをすべて取得
    tIndSubFolder = 0
    buf = Dir(fd_path & "*.*", vbDirectory)
    Do While buf <> ""
        If GetAttr(fd_path & "\" & buf) And vbDirectory Then
            If buf <> "." And buf <> ".." Then
                ReDim Preserve tSubFolders(tIndSubFolder)
                tSubFolders(tIndSubFolder) = buf
                tIndSubFolder = tIndSubFolder + 1
            End If
        End If
        buf = Dir()
    Loop
    If tIndSubFolder > 0 Then
        For tIndSubFolder = 0 To UBound(tSubFolders)
           ' サブフォルダ配下のファイルを全て取得
            buf = Dir(fd_path & "\" & tSubFolders(tIndSubFolder) & "*.*")
            Do While buf <> ""
                Debug.Print tSubFolders(tIndSubFolder) & "\" & buf
                buf = Dir()
            Loop
        Next
    End If

埋め込みまではしてないですが

Comments

[kensproject]

やってみましたがまだ理解できず、このソースに入れ込む事ができません。
どなたかこのソースに埋め込んでいただけないでしょうか。
それを見て勉強します。

[jinoji]

今回の要件に限って言えば、
探す範囲が「自フォルダ＋1階層下のサブフォルダ」ということなので
xail2222さんが追記されたコードの
If buf <> "." And buf <> ".." Then のところを （"."は自フォルダ、".."は親フォルダの意味）
If buf <> ".." Then と変えてあげると、
対象フォルダのすべてを配列に格納できて、後の処理が一本化できるのではないか、と思いました。
（試したわけではないのでおかしかったらごめんなさい。）

[kensproject]

皆様ありがとうございます。
足りない頭で組込み、解析中です。

[kensproject]

素人の私でも理解できましたので>jinoji　さんをベストアンサーに致しましたが、xail2222さんに教わった事は理解出来るように頑張ります。　ありがとうございました。

[xail2222]

質問に提示のコードがDirを使っていたので私もDirを使って回答を書きましたが
実際には私はDirをほとんど使っていなくてjinojiさんの回答のようにFileSystemObjectを使ってやってます。
自分一人でやるだけであればDirは覚えなくてもいいと思いますが、Dirを使う人も居るので
人のコードを見たり触ったりすることがあるのであれば、Dirでのやり方も理解できるようになった方が良いと思います。

[kensproject]

分かりました！　理解できるようになります。
ありがとうございました。