VBA将多个工作簿合并为一个

我很难过！ 我试图从多个工作簿中复制数据文件夹中的数据并将其粘贴到一个主工作簿。 我有一个循环将通过文件夹中的每个工作簿，复制数据，然后将其粘贴到主工作簿。 问题是，我需要每次将数据粘贴到新列上。 例如，来自工作簿1的数据应该粘贴到列A中，工作簿2应该粘贴到列B等等。

我可以从代码中粘贴每个工作簿中的数据，但是它会将其复制到一行中。 我如何将它移动到下一列而不是移到下一行？

'Description: Combines all files in a folder to a master file. Sub MergeFiles() Dim path As String, ThisWB As String, lngFilecounter As Long Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet Dim Filename As String, Wkb As Workbook Dim CopyRng As Range, Dest As Range Dim RowofCopySheet As Integer RowofCopySheet = 2 ' Row to start on in the sheets you are copying from ThisWB = ActiveWorkbook.Name path = "C:\testing" Application.EnableEvents = False Application.ScreenUpdating = False Set shtDest = ActiveWorkbook.Sheets(1) Filename = Dir(path & "\*.xl*", vbNormal) If Len(Filename) = 0 Then Exit Sub Do Until Filename = vbNullString If Not Filename = ThisWB Then Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename) Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)) Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1) CopyRng.Copy Dest Wkb.Close False End If Filename = Dir() Loop Range("A1").Select Application.EnableEvents = True Application.ScreenUpdating = True MsgBox "Done!" End Sub 

Answer 1

考虑一下。

 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

Answer 2

我假设一切都工作正常 – 你只需要将目标列从A，B，到C，…随着macros的继续。

这是你可以做到的一个方法。

将此函数添加到您的代码中（上方/下方您当前的子项）：

 Function Col_Letter(lngCol As Long) As String Dim vArr vArr = Split(Cells(1, lngCol).Address(True, False), "$") Col_Letter = vArr(0) End Function 

然后用这个replace你的Do Until...循环：

 Dim col As Long col = 1 Do Until Filename = vbNullString If Not Filename = ThisWB Then Set Wkb = Workbooks.Open(Filename:=Path & "\" & Filename) Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)) colLetter = Col_Letter(col) Set Dest = shtDest.Range(colLetter & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1) CopyRng.Copy Dest Wkb.Close False col = col + 1 End If Filename = Dir() Loop 

Answer 3

像这样修改你的dest。

从

 Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1) 

至

 Set Dest = shtDest.Cells(1, Columns.Count).End(xlToLeft)(1, 2)