代码在Excel VBA上崩溃

Question

Every time I run this code, it crashes , I tried all that I can, but I just don't know which part is crashing and it's not telling me why. I need it to look through every cell until its respective amount and put into the current sheet.

Is there any advice or see anything that might help?

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

Ok, what your script does:

1. It sets a number for variable d . Based on this one it opens a workbook.
2. Next, it uses variable c to start looping at a specific worksheet until it finds the Sheet in the opened workbook that has the same name as the sheet that is active when the macro starts ( Set currentsheet = Application.ActiveSheet )
3. It sets variable a to decide from which Column to 52 it must copy.
4. It sets variable b to decide from which Row to 99 it must copy.

Thus, based on this a,b,c,d you find 1 worksheet, in 1 workbook and you copy 1 range to the currentsheet. This basically means 1 operation, yet with your loops you make it a potential million operations. Hence the comment section and the incredibly slow performance.

This script does the exact same thing as yours without any loops:

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

You'll see that this executes a few hundred (!!!) times faster than the posted script.

Edit: To loop over each worksheet that is in the ActiveWorkbook and each corresponding sheet in the workbooks, I suggest changing the workbook names from "1st", "2nd", "3rd" etc. to simply 1, 2, 3, 4.

Then: - get rid of the d = 1 line - get rid of c altogether - get rid of the whole Select Case block above. - Replace the part from Set wbook = ... until the last end if with the code below:

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