如何將一個文件夾中的多個文件複製到一個電子表格中？

Question

我剛開始使用excel宏。我的問題是，我有一個文件夾中的500個Excel文件。我正在尋找一種方法將這500個文件中的每一個的第一列和第二列複製到一個電子表格中。這是可以使用excel VBA完成的事情嗎？任何幫助表示讚賞。請參閱我錄製的VBA代碼。我如何修改這個來實現我的目標？

Sub Macro1() 
' 
' Macro1 Macro 
' 

' 
    ActiveCell.Range("A1:B1").Select 
    Range(Selection, Selection.End(xlDown)).Select 
    Selection.Copy 
    Windows("Book1").Activate 
    ActiveSheet.Paste 
End Sub 

Answer 1

請在代碼中閱讀我的評論。

您必須更正您的路徑（地址），文件夾名稱和文件名。

Option Explicit 

Sub LoopAllFiles() 
Dim myCalc As XlCalculation 
Application.EnableCancelKey = xlDisabled 
Application.ScreenUpdating = False 
Application.Calculation = myCalc 
Application.Calculation = xlCalculationManual 
Dim folderPath As String 
Dim Filename As String 
Dim wb As Workbook, wbMaster As Workbook 
Dim sh As Worksheet 
Dim ColNo As Long 
    ColNo = 1 
folderPath = "C:\testfolder\" 'contains folder path 
'or folderPath = "C:\Users\AshleyLarson\Desktop\LoopThroughFolders\AnyFolder\" 
' ==> Please correct your path otherwise code won't work. <== 
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\" 
Filename = Dir(folderPath & "*.xlsx") 
Do While Filename <> "" 

    Set wb = Workbooks.Open(folderPath & Filename) 
    Set wbMaster = Workbooks.Open(folderPath & "masterfolder\Master Template.xlsx") ' BE CAREFUL This should be your Master File's path 

    wb.Sheets(1).Range("A1:B" & (Range("A" & Rows.Count).End(xlUp).Row) + 100).Copy 

    Workbooks("Master Template").Worksheets("Sheet1").Range(Chr(ColNo + 64) & ":" & Chr((ColNo + 1) + 64)).PasteSpecial xlPasteValues 
    ColNo = ColNo + 2 
    Application.DisplayAlerts = False 
    Workbooks(Filename).Save 
    Workbooks(Filename).Close 
    Workbooks("Master Template.xlsx").Save 
    Workbooks("Master Template.xlsx").Close 
    Application.DisplayAlerts = True 
    Filename = Dir 
Loop 
    Application.ScreenUpdating = True 
    Application.Calculation = myCalc 
End Sub 

Answer 2

這可以在電源的查詢來完成與絲帶圖標只需點擊幾下。不需要VBA。

從文件啓動一個新的查詢

• 導航到文件夾
• 選擇所有文件
• 刪除文件不帶過濾器的需要（可選步驟）
• 結合二進制
• 選擇你想保留的列

如果文件夾中的文件發生更改，只需刷新查詢即可。

Power Query是Microsoft爲Excel 2010和2013提供的一個免費加載項，並且內置到Excel 2016中，如獲取& Transform。

Answer 3

試試這個方法。

Sub Basic_Example_1() 
    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 

    'Fill in the path\folder where the files are 
    MyPath = "C:\Users\Ron\test" 

    'Add a slash at the end if the user forget it 
    If Right(MyPath, 1) <> "\" Then 
     MyPath = MyPath & "\" 
    End If 

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

    'Fill the array(myFiles)with the list of Excel files in the folder 
    Fnum = 0 
    Do While FilesInPath <> "" 
     Fnum = Fnum + 1 
     ReDim Preserve MyFiles(1 To Fnum) 
     MyFiles(Fnum) = FilesInPath 
     FilesInPath = Dir() 
    Loop 

    'Change ScreenUpdating, Calculation and EnableEvents 
    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 array(myFiles) 
    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 

       With mybook.Worksheets(1) 
        Set sourceRange = .Range("A1:C1") 
       End With 

       If Err.Number > 0 Then 
        Err.Clear 
        Set sourceRange = Nothing 
       Else 
        'if SourceRange use 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 "Sorry there are not enough rows in the sheet" 
         BaseWks.Columns.AutoFit 
         mybook.Close savechanges:=False 
         GoTo ExitTheSub 
        Else 

         'Copy the file name in column A 
         With sourceRange 
          BaseWks.cells(rnum, "A"). _ 
            Resize(.Rows.Count).Value = MyFiles(Fnum) 
         End With 

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

         'we copy the values from the sourceRange to the destrange 
         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 ScreenUpdating, Calculation and EnableEvents 
    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
     .Calculation = CalcMode 
    End With 
End Sub 

https://www.rondebruin.nl/win/s3/win008.htm