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

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

1 个答案: