サブフォルダからExcelデータをインポートするためのVBA - 連結Excelファイル

Question

VBAを使用するのは初めてです。

私の状況：私は、フォルダからExcelファイルをインポートする必要があるmaster excel（2010）ファイルを持っています。既存のコードはほとんど機能しますが、サブフォルダを調べません。以下の重要な要件に加えて。助けてください！

所望の出力：

1. コードはコードがに座ったファイルをエクセル同じマスターにデータをインポートする代わりに、新しいExcelシートを作成しないでください

2. 現在、コードフェッチでは、親フォルダからのみファイルが取り出されます。どのサブフォルダでもExcelファイルを調べる必要があります

3. 現在のコードでは出力先のファイル形式が変更されていますが、出力先の形式は変更しません。 ' をアプリケーションのプロパティを復元する：（：ロンデブルーインMSDNから）

   Sub MergeAllWorkbooks() 
   Dim MyPath As String, FilesInPath As String 
   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 
   
   ' Change this to the path\folder location of your files. 
   MyPath = "C:\Users\zatin.dharmapuri\Desktop\Reviews" 
   
   ' 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 <> "" 
       FNum = FNum + 1 
       ReDim Preserve MyFiles(1 To FNum) 
       MyFiles(FNum) = FilesInPath 
       FilesInPath = Dir() 
   Loop 
   
   ' Set various application properties. 
   With Application 
       CalcMode = .Calculation 
       .Calculation = xlCalculationManual 
       .ScreenUpdating = False 
       .EnableEvents = False 
   End With 
   
   ' Add a new workbook with one sheet. 
   Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
   rnum = 1 
   
   ' 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(1) 
          Set sourceRange = .Range("B2:G50") 
         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. 
           With sourceRange 
            BaseWks.Cells(rnum, "L"). _ 
              Resize(.Rows.Count).Value = MyFiles(FNum) 
           End With 
   
           ' Set the destination range. 
           Set destrange = BaseWks.Range("A" & 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

4. は、定義された範囲

既存のコードから空の行をコピーしてはなりません。 は、アプリケーション .ScreenUpdating = Trueの .EnableEvents = End Subの

Answer 1

との真の .Calculation = CalcMode エンドでこれを行うには、いくつかの方法があります。 Ron deBruinのAddInを使うのが一番簡単な方法でしょう。

http://www.rondebruin.nl/win/addins/rdbmerge.htm

「サブフォルダを含める]というボックスをチェックします。