代碼在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