vba - Excel VBA 上的代码崩溃

Question

每次我运行这段代码时，它都会崩溃，我尽了一切努力，但我只是不知道哪个部分崩溃了，而且它没有告诉我原因。我需要它查看每个单元格，直到其各自的数量并放入当前工作表中。

有什么建议或看到任何可能有帮助的东西吗？

Sub bringbookstogether()

Dim currentsheet As Worksheet
Set currentsheet = Application.ActiveSheet

'assigns the number to start with
Dim a, b, c, d As Integer

a = 4
b = 6
c = 3
d = 1

Dim wsheet As Worksheet
Set wsheet = Application.ActiveWorkbook.Sheets(c)

Dim wbook As Workbook

'assigns workbook numbers
If (d = 1) Then
    Set wbook = Workbooks.Open("C:\Users\mminchuk\Documents\Updated MaintPrep Sheets\MaintPrep Sheet 1st.xlsm", UpdateLinks:=xlUpdateLinksAlways)
Else

    If (d = 2) Then
        Set wbook = Workbooks.Open("C:\Users\mminchuk\Documents\Updated MaintPrep Sheets\MaintPrep Sheet 2nd.xlsm", UpdateLinks:=xlUpdateLinksAlways)
    Else

        If (d = 3) Then
            Set wbook = Workbooks.Open("C:\Users\mminchuk\Documents\Updated MaintPrep Sheets\MaintPrep Sheet 3rd.xlsm", UpdateLinks:=xlUpdateLinksAlways)

        End If
    End If
End If

Application.ScreenUpdating = False
'End if it's done with all the workbooks

Do Until (d = 4)

    'Looks for the sheet that has the same name

    Do Until (c = 53)
        If (wsheet.Name = currentsheet.Name) Then

            'Ends in row 99
            Do Until (b = 99)

                'Ends in Column 52
                Do Until (a = 52)

                    currentsheet.Cells(b, a) = currentsheet.Cells(b, a) + Workbooks(d).Sheets(c).Cells(b, a)

                    a = a + 1
                Loop

                b = b + 1
            Loop

        End If
    Loop

    d = d + 1
Loop

Application.ScreenUpdating = True

End Sub

Answer 1

好的，你的脚本是做什么的:

1. 它为变量d设置一个数字。基于此，它会打开一个工作簿。
2. 接下来，它使用变量 c 在特定工作表中开始循环，直到在打开的工作簿中找到与宏启动时处于事件状态的工作表同名的工作表 (设置currentsheet = Application.ActiveSheet)
3. 它设置变量 a 来决定必须从哪一列复制到 52。
4. 它设置变量 b 来决定必须从哪一行复制到 99。

因此，根据此 a,b,c,d，您可以在 1 个工作簿中找到 1 个工作表，并将 1 个范围复制到当前工作表。这基本上意味着 1 次操作，但通过循环，您可以使其成为潜在的百万次操作。因此评论部分和极其缓慢的性能。

这个脚本与您的脚本执行完全相同的操作，没有任何循环:

Sub bringbookstogether()
Application.ScreenUpdating = False

Dim currentsheet As Worksheet
Dim wbook As Workbook
Dim wsheet As Worksheet

Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim d As Integer

Dim fName As String

a = 1 'Only for the starting column! Can't exceed 52
b = 1 'Only for the starting row! Cant' exceed 99
      'I got rid of c, we don't need it.
d = 4 'Not needed to loop. Your loop on d was obsolete.

Set currentsheet = Application.ActiveSheet

'Open the workbook:
Select Case d 'No need for a lot of nested If statements.
    Case 1:
        fName = "C:\Users\mminchuk\Documents\Updated MaintPrep Sheets\MaintPrep Sheet 1st.xlsm"
    Case 2:
        fName = "C:\Users\mminchuk\Documents\Updated MaintPrep Sheets\MaintPrep Sheet 2nd.xlsm"
    Case 3:
        fName = "C:\Users\mminchuk\Documents\Updated MaintPrep Sheets\MaintPrep Sheet 3rd.xlsm"
        'You might want to consider renaming the files "MaintPrep Sheet 1.xlsm", "MaintPrep Sheet 2.xlsm", etc.
        'In that case you could just do: fName = "C:Users\mminchuk\Documents\Updated MaintPrep Sheets\MaintPrep Sheet " & d & ".xlsm" and omit the whole Select.
    Case 4:
        fName = "C:\temp\test.xlsx"
End Select

Set wbook = Workbooks.Open(fName, UpdateLinks:=xlUpdateLinksAlways)

On Error Resume Next 'To avoid subscript out of range error if the same named sheet doesn't exist
    Set wsheet = wbook.Worksheets(currentsheet.Name)
On Error GoTo 0

If Not wsheet Is Nothing Then 'Check if we have the sheet with the same name
    With currentsheet 'Copy range row set in a, column set in a to row 99 and column 52 as per sample loop.
        wsheet.Range(wsheet.Cells(b, a), wsheet.Cells(99, 52)).Copy
        .Range(.Cells(b, a), .Cells(99, 52)).PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
    End With
End If

Application.ScreenUpdating = True
End Sub

您会发现它的执行速度比发布的脚本快几百(!!!)倍。

编辑:要循环 ActiveWorkbook 中的每个工作表以及工作簿中的每个相应工作表，我建议将工作簿名称从“1st”、“2nd”、“3rd”等更改为简单的 1、2、3、4。

然后: - 去掉d = 1行 - 完全摆脱c - 去掉上面的整个Select Case block 。 - 将 Set wbook = ... 到最后一个 end if 的部分替换为以下代码:

For d = 1 to 4
    fName = "C:Users\mminchuk\Documents\Updated MaintPrep Sheets\MaintPrep Sheet " & d & ".xlsm"
    Set wbook = Workbooks.Open(fName, UpdateLinks:=xlUpdateLinksAlways)

    For Each currentSheet in ThisWorkbook.Worksheets
    On Error Resume Next 'To avoid subscript out of range error if the same named sheet doesn't exist
        Set wsheet = wbook.Worksheets(currentsheet.Name)
    On Error GoTo 0

    If Not wsheet Is Nothing Then 'Check if we have the sheet with the same name
        With currentsheet 'Copy range row set in a, column set in a to row 99 and column 52 as per sample loop.
            wsheet.Range(wsheet.Cells(b, a), wsheet.Cells(99, 52)).Copy
            .Range(.Cells(b, a), .Cells(99, 52)).PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
        End With
    End If
    Next currentSheet
Next d