使用VBA合并具有多个工作表的多个工作簿

我一直有这个问题的VBA要么没有一个对象，我想要合并的新表，或者有下标超出范围问题出现。 我试过的东西都没有结束工作。

Private Sub MergeButton_Click() Dim filename As Variant Dim wb As Workbook Dim s As Sheet1 Dim thisSheet As Sheet1 Dim lastUsedRow As Range Dim j As Integer On Error GoTo ErrMsg Application.ScreenUpdating = False Set thisSheet = ThisWorkbook.ActiveSheet MsgBox "Reached method" 'j is for the sheet number which needs to be created in 2,3,5,12,16 For Each Sheet In ActiveWorkbook.Sheets For i = 0 To FilesListBox.ListCount - 1 filename = FilesListBox.List(i, 0) 'Open the spreadsheet in ReadOnly mode Set wb = Application.Workbooks.Open(filename, ReadOnly:=True) 'Copy the used range (ie cells with data) from the opened spreadsheet If FirstRowHeadersCheckBox.Value And i > 0 Then 'Only include headers from the first spreadsheet Dim mr As Integer mr = wb.ActiveSheet.UsedRange.Rows.Count wb.ActiveSheet.UsedRange.Offset(3, 0).Resize(mr - 3).Copy Else wb.ActiveSheet.UsedRange.Copy End If 'thisSheet = ThisWorkbook.Worksheets(SheetCurr) 'Paste after the last used cell in the master spreadsheet If Application.Version < "12.0" Then 'Excel 2007 introduced more rows Set lastUsedRow = thisSheet.Range("A65536").End(xlUp) Else Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp) End If 'Only offset by 1 if there are current rows with data in them If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then Set lastUsedRow = lastUsedRow.Offset(1, 0) End If lastUsedRow.PasteSpecial Application.CutCopyMode = False Next i 

这是我试图添加一个额外的循环，复制下一张（这是Sheet12），但它出现了下标我们的范围错误。

  Sheets("Sheet3").Activate Sheet.Copy After:=ThisWorkbook.Sheets Next Sheet 

然后它将移动到下一张表格再次执行循环。

 ThisWorkbook.Save Set wb = Nothing #If Mac Then 'Do nothing. Closing workbooks fails on Mac for some reason #Else 'Close the workbooks except this one Dim file As String For i = 0 To FilesListBox.ListCount - 1 file = FilesListBox.List(i, 0) file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1)) Workbooks(file).Close SaveChanges:=False Next i #End If Application.ScreenUpdating = True Unload Me ErrMsg: If Err.Number <> 0 Then MsgBox "There was an error. Please try again. [" & Err.Description & "]" End If End Sub 

任何帮助，这将是伟大的

Answer 1

您的源代码非常混乱，我相信您会ActiveWorkbook ，因为每次打开新的工作簿时， ActiveWorkbook和ActiveSheet发生变化。 也不清楚为什么要复制/合并每个打开的工作簿中的每个工作表中的数据，然后复制Sheet3 。 您将通过更清楚地定义数据的内容和位置以及如何移动数据来帮助自己。

作为一个例子（这可能不会解决你的问题，因为你的问题不清楚），看看下面的代码，看看如何保持你的循环内源和目的地。 根据需要修改此示例，以便与您的具体情况相匹配。

 Sub Merge() '--- assumes that each sheet in your destination workbook matches a sheet ' in each of the source workbooks, then copies the data from each source ' sheet and merges/appends that source data to the bottom of each ' destination sheet Dim destWB As Workbook Dim srcWB As Workbook Dim destSH As Worksheet Dim srcSH As Worksheet Dim srcRange As Range Dim i As Long Application.ScreenUpdating = False Set destWB = ThisWorkbook For i = 0 To FileListBox.ListCount - 1 Set srcWB = Workbooks.Open(CStr(FileListBox(i, 0)), ReadOnly:=True) For Each destSH In destWB.Sheets Set srcSH = srcWB.Sheets(destSH.Name) 'target the same named worksheet lastdestrow = destSH.Range("A").End(xlUp) srcSH.UsedRange.Copy destSH.Range(Cells(lastdestrow, 1)) Next destSH srcWB.Close Next i Application.ScreenUpdating = True End Sub