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