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次操作，但是通過循環，您可以使其成爲潛在的百萬次操作。因此評論部分和非常緩慢的表現。

這個腳本做同樣的事情和你沒有任何的循環：

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和每個對應片在工作簿的每個工作表上，我建議從「第一」，「第二」改變工作簿名，「第三」等簡單地1 ，2，3，4，

然後： - 擺脫d = 1線 的 - 擺脫c共 - 獲取上述去掉整個Select Case塊。 - 從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