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

好的，你的脚本做了什么：

它为变量d设置一个数字。基于此，它打开了一个工作簿。
接下来，它使用变量c开始在特定工作表上循环，直到它在打开的工作簿中找到与宏启动时处于活动状态的工作表同名的工作表（Set currentsheet = Application.ActiveSheet ）
设置变量a以决定从哪个列到52必须复制。
设置变量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中的每个工作表和工作簿中的每个相应工作表，我建议更改工作簿名称，从＃34; 1st＆＃34;，＆＃34; 2nd＆＃34;，＆＃34; 3rd＆＃34 ;等等，只需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

代码在Excel VBA上崩溃

1 个答案: