使用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 (i.e. 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

然后，它将移动到下一张图纸以再次执行循环

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

ThisWorkbook.Save
设置wb=Nothing
#如果是Mac那么
“什么也不做。由于某些原因，在Mac上关闭工作簿失败
#否则
'关闭除此之外的工作簿
将文件设置为字符串
对于filelistbox.ListCount-1的i=0
file=filelistbox.List（i，0）
file=Right（文件，Len（文件）-InStrRev（文件，Application.PathSeparator，1））
工作簿（文件）。关闭保存更改：=False
接下来我
#如果结束
Application.ScreenUpdating=True
卸下我
错误消息：
如果错误号为0，则
MsgBox“出现错误。请重试。[”&Err.Description&“]
如果结束
端接头

---

任何关于这方面的帮助都将是非常好的

您的源代码非常混乱，我相信您会遇到障碍，因为每次打开新工作簿时，

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

---

您的源代码非常混乱，我认为您遇到了问题，因为每次打开新工作簿时，

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

---

Sheet3

与

ActiveWorkbook

在不同的工作簿中吗？我建议大家通读一下，这有助于收紧代码。我总是尽量避免硬编码表名。公司里总有人不小心在名字上加了一个空格（

Sheet3

变成了

Sheet3

）或一个点，代码就不起作用了。我非常建议您添加一个验证过程，以确保工作表实际存在（如下所示）：

用于此工作簿中的每个ws。工作表：调试。打印ws.Name&“：”&IIf（ws.Name=“Sheet3”，“got it”，“search”）：下一个ws

是

Sheet3

在与

ActiveWorkbook

不同的工作簿中？我建议大家通读一下，这有助于收紧代码。我总是尽量避免硬编码表名。公司里总有人不小心在名字上加了一个空格（

Sheet3

变成了

Sheet3

）或一个点，代码就不起作用了。我非常建议您添加一个验证过程，以确保此工作簿中每个ws的工作表实际存在（如下所示）：

。工作表：Debug.Print ws.Name&“：”&IIf（ws.Name=“Sheet3”，“got it”，“search”）：Next ws