VBA - フォルダとサブフォルダ内のすべてのブックから範囲をマージする

Question

「E：\ Dian \ Test」というメインフォルダにファイルがある場合、以下のコードはうまく動作します。 （メインフォルダ（MyPath）にコピーされたファイルのみがサブフォルダ内のファイルではない）

私の質問は、既存のコードにどのようにループを組み込んでサブフォルダを介してE ：\ Dian \ Testフォルダ、名前が "out_ *"で始まる.xlsxファイルの場合

プログラミングスキルはあまり良くありません。

ありがとうございました:)この種の問題のために

Private Sub CommandButton1_Click() 

Dim MyPath As String, FilesInPath As String 
Dim myCountFiles As Long 
Dim myFiles() As String 
Dim SourceRcount As Long, Fnum As Long 
Dim mybook As Workbook, BaseWks As Worksheet 
Dim sourceRange As Range, destrange As Range 
Dim rnum As Long, CalcMode As Long 
Dim FirstCell As String 
Dim emptyColumn As Long 
Dim NextRow As Range 

' Change this to the path\folder location of your files.' 

'How do you include a loop to include searching through SubFolders, within the E:\Dian\Test folder, for xlsx files starting with the name "out_*"??????????????????????????????????????' 

MyPath = "E:\Dian\Test\" 

' Add a slash at the end of the path if needed. 
If Right(MyPath, 1) <> "\" Then 
MyPath = MyPath & "\" 
End If 

' If there are no Excel files in the folder, exit. 
FilesInPath = Dir(MyPath & "*.xl*") 
If FilesInPath = "" Then 
    MsgBox "No files found" 
    Exit Sub 
End If 

' Fill the myFiles array with the list of Excel files 
' in the search folder. 
Fnum = 0 
Do While FilesInPath <> "" 
    If FilesInPath <> ActiveWorkbook.Name Then 
    Fnum = Fnum + 1 
    ReDim Preserve myFiles(1 To Fnum) 
    myFiles(Fnum) = FilesInPath 
End If 
FilesInPath = Dir() 

Loop 

' Set various application properties. 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Add a new workbook/existing sheet. 
If Workbooks.Count > 1 Then 
Call MsgBox("Please close all other workbooks", vbOKOnly) 
Exit Sub 
End If 

Set BaseWks = ActiveWorkbook.Worksheets("1_Input_Data") 
With BaseWks 
    rnum = .Cells(Rows.Count, "A").End(xlUp).Row + 1 
End With 

' Loop through all files in the myFiles array. 
If Fnum > 0 Then 
    For Fnum = LBound(myFiles) To UBound(myFiles) 
     Set mybook = Nothing 
     On Error Resume Next 
     Set mybook = Workbooks.Open(MyPath & myFiles(Fnum)) 
     On Error GoTo 0 

     If Not mybook Is Nothing Then 
      On Error Resume Next 

      ' Change this range to fit your own needs. 
      With mybook.Worksheets("Summary") 

FirstCell = "A4" 
Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells)) 
' Test if the row of the last cell is equal to or greater than the row of the first cell. 
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then 
    Set sourceRange = Nothing 
End If 

End With 

      If Err.Number > 0 Then 
       Err.Clear 
       Set sourceRange = Nothing 
      Else 
       ' If source range uses all columns then 
       ' skip this file. 
       If sourceRange.Columns.Count >= BaseWks.Columns.Count Then 
        Set sourceRange = Nothing 
       End If 
      End If 
      On Error GoTo 0 

      If Not sourceRange Is Nothing Then 

       SourceRcount = sourceRange.Rows.Count 

       If rnum + SourceRcount >= BaseWks.Rows.Count Then 
        MsgBox "There are not enough rows in the target worksheet." 
        BaseWks.Columns.AutoFit 
        mybook.Close SaveChanges:=False 
        GoTo ExitTheSub 
       Else 

        ' Copy the file name in column A. 
        With sourceRange 
         BaseWks.UsedRange(rnum, "A"). _ 
           Resize(.Rows.Count).Value = Mid(myFiles(Fnum), WorksheetFunction.Find("out_", myFiles(Fnum)) + 4, WorksheetFunction.Find(".xlsx", myFiles(Fnum)) - WorksheetFunction.Find("out_", myFiles(Fnum)) - 4) 

        End With 

        ' Set the destination range. 
        Set destrange = BaseWks.Range("B" & rnum) 



        ' Copy the values from the source range 
        ' to the destination range. 
        With sourceRange 
         Set destrange = destrange. _ 
          Resize(.Rows.Count, .Columns.Count) 

        End With 
        destrange.Value = sourceRange.Value 


        rnum = rnum + SourceRcount 
       End If 
      End If 
      mybook.Close SaveChanges:=False 
     End If 

    Next Fnum 
    BaseWks.Columns.AutoFit 
End If 

ExitTheSub: 
    ' Restore the application properties. 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 
End Sub 

Answer 1

を、私は、コマンドシェルを使用していました。 PowerShellを使うこともできますが、私はそのコードを開発していません。

ここには、名前に特定のパターンを持つすべてのファイルを配列vFileListに配置する短いルーチンがあります。その後、その配列を反復することができます。

シェルdirコマンドは、スイッチ\Sと\Bを使用することに注意してください。 S \

はあなたのケースでは唯一の完全なファイルパス

を残し、B \ は、すべての余分な情報を削除し、このフォルダ内のアイテムおよびサブフォルダのすべてを読むことを意味し、あなたはおそらく設定します

MyPath = "E:\Dian\Test\out_*.xlsx" 



Option Explicit 
'set reference to Windows Script Host Object Model 
Sub GetFiles() 
    Const myPath As String = "D:\Users\Ron\b*.xlsx" 
    Dim WSH As WshShell 
    Dim vFileList As Variant 
Set WSH = New WshShell 
vFileList = Split(WSH.Exec("CMD /c dir """ & myPath & """/B /S").StdOut.ReadAll, vbLf) 
End Sub