如何将一个文件夹中的多个文件复制到一个电子表格中？
我刚开始使用Excelmacros。 我的问题是，我有一个文件夹中的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 请在代码中阅读我的意见。
您必须纠正您的path（地址），文件夹名称和文件名称。
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
只需点击几个function区图标，即可在Power Query中完成此操作。 不需要VBA。
开始一个新的查询
- 从文件
- 导航到文件夹
- select所有文件
- 使用filter删除不需要的文件（可选步骤）
- 结合二进制文件
- select你想保留的列
如果文件夹中的文件发生更改，则只需刷新查询即可。
Power Query是Microsoft为Excel 2010和2013提供的免费插件，并以Get＆Transform的forms构build到Excel 2016中。
试试这种方式。
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