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

Question

我一直存在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 

这是我尝试添加一个额外的循环，副本的下一个片（这是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和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