代码在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在特定的工作表上开始循环，直到在打开的工作簿中找到与宏启动时处于活动状态的工作表同名的工作表为止（ Set currentsheet = Application.ActiveSheet ）
3. 它设置变量a来决定必须从哪个列复制到52。
4. 它设置变量b来决定必须从哪个行复制到99。

因此，基于此a,b,c,d ，您将在1个工作簿中找到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块。 - end if使用以下代码， end if 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