使用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