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

问题描述

我一直遇到这样的VBA问题:要么没有要合并的新工作表的对象，要么出现下标超出范围的问题.我尝试过的所有方法都没有奏效.

I keep having this issue of VBA either not having an object for the new sheet I want to merge, or having the subscript out of range issue come up. None of the things I tried ended up working.

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)，但是它带有下标我们的范围错误.

This is where I try to add an extra loop that copies the next sheet (which is Sheet12) but it comes up with the Subscript our of range error.

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

然后它将移至下一张纸以再次执行循环.

It will then move to the next sheet to perform the loop again.

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

任何帮助，这都很棒

推荐答案

您的源代码非常令人困惑，并且我相信您正在绊脚石，因为 ActiveWorkbook 和 ActiveSheet 发生了变化每次您打开新工作簿时.还不清楚为什么要复制/合并每个打开的工作簿中每个工作表中的数据，然后复制 Sheet3 .通过更清楚地定义数据的位置和位置以及如何移动数据，您将为自己提供帮助.

Your source code is very confusing and I believe you're stumbling because the ActiveWorkbook and ActiveSheet change each time you open a new workbook. It's also not clear why you're copying/merging the data from each worksheet in every opened workbook and then copying Sheet3. You will help yourself by more clearly defining what and where your data is and how you're moving it around.

作为示例(由于问题尚不清楚，可能不能解决您的问题)，请查看下面的代码，以了解如何在循环中保持源和目的地的直接.为了满足您的实际情况，可以根据需要修改此示例.

As an example (that may not solve your problem, because your problem is not clear), look at the code below to see how you can keep the sources and destinations straight within your loops. Modify this example as much as you need in order to match your exact situation.

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

这篇关于使用VBA合并具有多个工作表的多个工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！