VBA代码滞后-如何加快它？_Vba_Excel

VBA代码滞后-如何加快它？

vba excel

VBA代码滞后-如何加快它？,vba,excel,Vba,Excel,在此方面如有任何帮助，将不胜感激我有以下代码，它使用特定名称（例如SheetA、Sheetb等）浏览工作簿1上的工作表。工作表匹配后，如果某个临界值与“选择”工作表匹配，它将开始从工作簿1中复制工作表中的值，并将其粘贴到工作簿2中我希望工作簿1中的数据在工作簿2中的现有数据下写入，而不是覆盖，这正是它所做的。然而，我的代码现在正在一个接一个地进行复制/粘贴有人告诉我，如果我将值保存到变量中并将它们写入单元格中，我就可以加快速度，但我不知道该怎么做 Public Sub Validation

在此方面如有任何帮助，将不胜感激

我有以下代码，它使用特定名称（例如SheetA、Sheetb等）浏览工作簿1上的工作表。工作表匹配后，如果某个临界值与“选择”工作表匹配，它将开始从工作簿1中复制工作表中的值，并将其粘贴到工作簿2中

我希望工作簿1中的数据在工作簿2中的现有数据下写入，而不是覆盖，这正是它所做的。然而，我的代码现在正在一个接一个地进行复制/粘贴

有人告诉我，如果我将值保存到变量中并将它们写入单元格中，我就可以加快速度，但我不知道该怎么做

Public Sub Validation()
    Dim ws As Worksheet
    Dim iCounter As Long
    Dim wkb1 As Workbook
    Dim wkb2 As Workbook
    Dim ws1 As Worksheet
    Dim rw As Long
    Dim rw1 As Long
    Dim rw2 As Long
    Dim rw3 As Long
    Dim rw4 As Long
    Dim lastrow As Long
    Dim WS2 As Worksheet
    Dim ws3 As Worksheet
    Dim ws4 As Worksheet
    Dim ws5 As Worksheet
    Dim ws6 As Worksheet

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set wkb2 = Workbooks.Open("workbook2xlsx")
    Set WS2 = wkb2.Sheets("sheeta")
    Set ws3 = wkb2.Sheets("sheetb")
    Set ws4 = wkb2.Sheets("sheetc")
    Set ws5 = wkb2.Sheets("sheetd")
    Set ws6 = wkb2.Sheets("sheetf")
    rw = WS2.Cells(WS2.Rows.Count, "A").End(xlUp).Row + 1
    rw1 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row + 1
    rw2 = ws4.Cells(ws4.Rows.Count, "A").End(xlUp).Row + 1
    rw3 = ws5.Cells(ws5.Rows.Count, "A").End(xlUp).Row + 1
    rw4 = ws6.Cells(ws6.Rows.Count, "A").End(xlUp).Row + 1

    Set wkb1 = ThisWorkbook
    wkb1.Activate

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name Like "*" & "sheeta" & "*" Then
            ws.Select
            If ws.Cells(5, 2).Value = "COMPLETE" Then
                Cells(9, 1).Copy
                WS2.Cells(rw, 1).PasteSpecial Paste:=xlPasteValues
                Cells(29, 2).Copy
                WS2.Cells(rw, 2).PasteSpecial Paste:=xlPasteValues
                Cells(29, 3).Copy
                WS2.Cells(rw, 3).PasteSpecial Paste:=xlPasteValues
                Cells(15, 1).Copy
                WS2.Cells(rw, 4).PasteSpecial Paste:=xlPasteValues
                Cells(39, 1).Copy
                WS2.Cells(rw, 5).PasteSpecial Paste:=xlPasteValues
                Cells(39, 2).Copy
                WS2.Cells(rw, 6).PasteSpecial Paste:=xlPasteValues
                Cells(39, 3).Copy
                WS2.Cells(rw, 7).PasteSpecial Paste:=xlPasteValues
                Cells(55, 1).Copy
                WS2.Cells(rw, 8).PasteSpecial Paste:=xlPasteValues
                Cells(55, 2).Copy
                WS2.Cells(rw, 9).PasteSpecial Paste:=xlPasteValues
                Cells(55, 3).Copy
                WS2.Cells(rw, 10).PasteSpecial Paste:=xlPasteValues
                Cells(55, 4).Copy
                WS2.Cells(rw, 11).PasteSpecial Paste:=xlPasteValues

                Cells(57, 1).Copy
                WS2.Cells(rw, 12).PasteSpecial Paste:=xlPasteValues
                Cells(57, 2).Copy
                WS2.Cells(rw, 13).PasteSpecial Paste:=xlPasteValues
                Cells(57, 3).Copy
                WS2.Cells(rw, 14).PasteSpecial Paste:=xlPasteValues
                Cells(57, 4).Copy
                WS2.Cells(rw, 15).PasteSpecial Paste:=xlPasteValues
                Cells(59, 1).Copy
                WS2.Cells(rw, 16).PasteSpecial Paste:=xlPasteValues
                Cells(59, 2).Copy
                WS2.Cells(rw, 17).PasteSpecial Paste:=xlPasteValues
                Cells(59, 3).Copy
                WS2.Cells(rw, 18).PasteSpecial Paste:=xlPasteValues
                Cells(59, 4).Copy
                WS2.Cells(rw, 19).PasteSpecial Paste:=xlPasteValues

                Cells(61, 1).Copy
                WS2.Cells(rw, 20).PasteSpecial Paste:=xlPasteValues
                Cells(61, 2).Copy
                WS2.Cells(rw, 21).PasteSpecial Paste:=xlPasteValues
                Cells(3, 2).Copy
                WS2.Cells(rw, 22).PasteSpecial Paste:=xlPasteValues
                Cells(4, 2).Copy
                WS2.Cells(rw, 23).PasteSpecial Paste:=xlPasteValues

            End If

        End If

        If ws.Name Like "*" & "sheetb" & "*" Then
            ws.Select
            If ws.Cells(5, 2).Value = "COMPLETE" Then

                Cells(9, 1).Copy
                ws3.Cells(rw1, 1).PasteSpecial Paste:=xlPasteValues
                Cells(9, 2).Copy
                ws3.Cells(rw1, 2).PasteSpecial Paste:=xlPasteValues
                Cells(26, 1).Copy
                ws3.Cells(rw1, 3).PasteSpecial Paste:=xlPasteValues
                Cells(14, 1).Copy
                ws3.Cells(rw1, 4).PasteSpecial Paste:=xlPasteValues
                Cells(26, 2).Copy
                ws3.Cells(rw1, 5).PasteSpecial Paste:=xlPasteValues
                Cells(26, 3).Copy
                ws3.Cells(rw1, 6).PasteSpecial Paste:=xlPasteValues
                Cells(30, 4).Copy
                ws3.Cells(rw1, 7).PasteSpecial Paste:=xlPasteValues
                Cells(32, 4).Copy
                ws3.Cells(rw1, 8).PasteSpecial Paste:=xlPasteValues

                Cells(46, 1).Copy
                ws3.Cells(rw1, 9).PasteSpecial Paste:=xlPasteValues
                Cells(46, 2).Copy
                ws3.Cells(rw1, 10).PasteSpecial Paste:=xlPasteValues
                Cells(46, 3).Copy
                ws3.Cells(rw1, 11).PasteSpecial Paste:=xlPasteValues
                Cells(46, 4).Copy
                ws3.Cells(rw1, 12).PasteSpecial Paste:=xlPasteValues

                Cells(48, 1).Copy
                ws3.Cells(rw1, 13).PasteSpecial Paste:=xlPasteValues
                Cells(48, 2).Copy
                ws3.Cells(rw1, 14).PasteSpecial Paste:=xlPasteValues
                Cells(48, 3).Copy
                ws3.Cells(rw1, 15).PasteSpecial Paste:=xlPasteValues
                Cells(48, 4).Copy
                ws3.Cells(rw1, 16).PasteSpecial Paste:=xlPasteValues

                Cells(50, 1).Copy
                ws3.Cells(rw1, 17).PasteSpecial Paste:=xlPasteValues
                Cells(50, 2).Copy
                ws3.Cells(rw1, 18).PasteSpecial Paste:=xlPasteValues
                Cells(50, 3).Copy
                ws3.Cells(rw1, 19).PasteSpecial Paste:=xlPasteValues
                Cells(50, 4).Copy
                ws3.Cells(rw1, 20).PasteSpecial Paste:=xlPasteValues

                Cells(52, 4).Copy
                ws3.Cells(rw1, 21).PasteSpecial Paste:=xlPasteValues

                Cells(3, 2).Copy
                ws3.Cells(rw1, 22).PasteSpecial Paste:=xlPasteValues
                Cells(4, 2).Copy
                ws3.Cells(rw1, 23).PasteSpecial Paste:=xlPasteValues

            End If
        End If

        If ws.Name Like "*" & "sheetc" & "*" Then
            ws.Select
            If ws.Cells(5, 2).Value = "COMPLETE" Then

                Cells(9, 1).Copy
                ws4.Cells(rw2, 1).PasteSpecial Paste:=xlPasteValues
                Cells(9, 3).Copy
                ws4.Cells(rw2, 2).PasteSpecial Paste:=xlPasteValues
                Cells(9, 2).Copy
                ws4.Cells(rw2, 3).PasteSpecial Paste:=xlPasteValues
                Cells(23, 1).Copy
                ws4.Cells(rw2, 4).PasteSpecial Paste:=xlPasteValues
                Cells(19, 2).Copy
                ws4.Cells(rw2, 5).PasteSpecial Paste:=xlPasteValues
                Cells(19, 3).Copy
                ws4.Cells(rw2, 6).PasteSpecial Paste:=xlPasteValues
                Cells(13, 1).Copy
                ws4.Cells(rw2, 7).PasteSpecial Paste:=xlPasteValues
                Cells(13, 2).Copy
                ws4.Cells(rw2, 8).PasteSpecial Paste:=xlPasteValues

                Cells(33, 1).Copy
                ws4.Cells(rw2, 9).PasteSpecial Paste:=xlPasteValues
                Cells(33, 2).Copy
                ws4.Cells(rw2, 10).PasteSpecial Paste:=xlPasteValues
                Cells(33, 3).Copy
                ws4.Cells(rw2, 11).PasteSpecial Paste:=xlPasteValues
                Cells(33, 4).Copy
                ws4.Cells(rw2, 12).PasteSpecial Paste:=xlPasteValues

                Cells(35, 1).Copy
                ws4.Cells(rw2, 13).PasteSpecial Paste:=xlPasteValues
                Cells(35, 2).Copy
                ws4.Cells(rw2, 14).PasteSpecial Paste:=xlPasteValues
                Cells(35, 3).Copy
                ws4.Cells(rw2, 15).PasteSpecial Paste:=xlPasteValues
                Cells(35, 4).Copy
                ws4.Cells(rw2, 16).PasteSpecial Paste:=xlPasteValues

                Cells(37, 1).Copy
                ws4.Cells(rw2, 17).PasteSpecial Paste:=xlPasteValues
                Cells(37, 2).Copy
                ws4.Cells(rw2, 18).PasteSpecial Paste:=xlPasteValues
                Cells(37, 3).Copy
                ws4.Cells(rw2, 19).PasteSpecial Paste:=xlPasteValues
                Cells(37, 4).Copy
                ws4.Cells(rw2, 20).PasteSpecial Paste:=xlPasteValues

                Cells(39, 4).Copy
                ws4.Cells(rw2, 21).PasteSpecial Paste:=xlPasteValues

                Cells(3, 2).Copy
                ws4.Cells(rw2, 22).PasteSpecial Paste:=xlPasteValues
                Cells(4, 2).Copy
                ws4.Cells(rw2, 23).PasteSpecial Paste:=xlPasteValues

            End If
        End If

        If ws.Name Like "*" & "sheetd" & "*" Then
            ws.Select
            If ws.Cells(5, 2).Value = "COMPLETE" Then

                Cells(9, 1).Copy
                ws5.Cells(rw3, 1).PasteSpecial Paste:=xlPasteValues
                Cells(9, 2).Copy
                ws5.Cells(rw3, 2).PasteSpecial Paste:=xlPasteValues
                Cells(9, 4).Copy
                ws5.Cells(rw3, 3).PasteSpecial Paste:=xlPasteValues
                Cells(13, 1).Copy
                ws5.Cells(rw3, 4).PasteSpecial Paste:=xlPasteValues
                Cells(13, 2).Copy
                ws5.Cells(rw3, 5).PasteSpecial Paste:=xlPasteValues
                Cells(13, 3).Copy
                ws5.Cells(rw3, 6).PasteSpecial Paste:=xlPasteValues

                Cells(21, 1).Copy
                ws5.Cells(rw3, 7).PasteSpecial Paste:=xlPasteValues


                Cells(17, 1).Copy
                ws5.Cells(rw3, 8).PasteSpecial Paste:=xlPasteValues
                Cells(17, 2).Copy
                ws5.Cells(rw3, 9).PasteSpecial Paste:=xlPasteValues
                Cells(17, 3).Copy
                ws5.Cells(rw3, 10).PasteSpecial Paste:=xlPasteValues

                Cells(3, 2).Copy
                ws5.Cells(rw3, 11).PasteSpecial Paste:=xlPasteValues
                Cells(4, 2).Copy
                ws5.Cells(rw3, 12).PasteSpecial Paste:=xlPasteValues

            End If
        End If

        If ws.Name Like "*" & "Sheetf" & "*" Then
            ws.Select
            If ws.Cells(5, 2).Value = "COMPLETE" Then

                Cells(9, 1).Copy
                ws6.Cells(rw4, 1).PasteSpecial Paste:=xlPasteValues
                Cells(9, 2).Copy
                ws6.Cells(rw4, 2).PasteSpecial Paste:=xlPasteValues
                Cells(9, 3).Copy
                ws6.Cells(rw4, 3).PasteSpecial Paste:=xlPasteValues
                Cells(11, 1).Copy
                ws6.Cells(rw4, 4).PasteSpecial Paste:=xlPasteValues
                Cells(15, 2).Copy
                ws6.Cells(rw4, 5).PasteSpecial Paste:=xlPasteValues
                Cells(15, 3).Copy
                ws6.Cells(rw4, 6).PasteSpecial Paste:=xlPasteValues

                Cells(3, 2).Copy
                ws5.Cells(rw3, 7).PasteSpecial Paste:=xlPasteValues
                Cells(4, 2).Copy
                ws5.Cells(rw3, 8).PasteSpecial Paste:=xlPasteValues

            End If
        End If

    Next ws

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

通过使用数组关闭应用程序计算、消除选择和减少写入次数，将加快代码的速度

Sub AppendRow(ws As Worksheet, ParamArray Args())
    With ws
        With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
            .Resize(1, UBound(Args(), 1) + 1) = Args
        End With
    End With
End Sub

Sub ToggleEvents(EnableEvents As Boolean)
    With Application
        .DisplayAlerts = EnableEvents
        .EnableEvents = EnableEvents
        .ScreenUpdating = EnableEvents
        .Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

我刚刚发布了一个答案。在这本书中，我假设最后两次复制操作都是打字错误。谢谢托马斯的帮助。我想知道-它看起来像是从预先命名的表格中提取数据-例如，对于“sheeta”，提取这些单元格，粘贴。我正在使用的工作簿要求Excel对所有命名类似于“sheeta”的工作表进行说明，即“sheeta（1）”到“sheeta（n）”，因为可能存在同名但末尾有一个（n）的重复工作表。我测试了上述代码，并得到“编译错误：无效或不合格引用”。我还尝试调整代码以查找具有类似名称的工作表，而不是使用activeworkbook.worksheets，我使用的是“If-ws.name Like”“&“Sheetf”&“Then-ws.Select”，无法将其用于工作耶，哈哈，很好！将xlcalculationmanual添加到我当前的代码中会将其缩短到6秒，不快也不慢，将尝试使用您提供的内容使其更精确，谢谢您的帮助：）我刚刚更新了我的答案。这次我通过编程从代码中提取了单元格，以避免出错。让我知道它是如何工作的。谢谢托马斯！看起来appendrow子代码是代码中最大的部分

Public Sub Validation()
    ToggleEvents False
    Dim ws As Worksheet
    Dim wkb1 As Workbook: Set wkb1 = ThisWorkbook
    Dim wkb2 As Workbook: Set wkb2 = Workbooks.Open("workbook2xlsx")
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            If .Cells(5, 2).Value = "COMPLETE" Then
                If .Name Like "*sheeta*" Then
                    AppendRow wkb2.Worksheets("sheeta"), .Cells(9, 1), .Cells(29, 2), .Cells(29, 3), .Cells(15, 1), .Cells(39, 1), .Cells(39, 2), .Cells(39, 3), .Cells(55, 1), .Cells(55, 2), .Cells(55, 3), .Cells(55, 4), .Cells(57, 1), .Cells(57, 2), .Cells(57, 3), .Cells(57, 4), .Cells(59, 1), .Cells(59, 2), .Cells(59, 3), .Cells(59, 4), .Cells(61, 1), .Cells(61, 2), .Cells(3, 2), .Cells(4, 2)
                ElseIf .Name Like "*sheetb*" Then
                    AppendRow wkb2.Worksheets("sheetb"), .Cells(9, 1), .Cells(9, 2), .Cells(26, 1), .Cells(14, 1), .Cells(26, 2), .Cells(26, 3), .Cells(30, 4), .Cells(32, 4), .Cells(46, 1), .Cells(46, 2), .Cells(46, 3), .Cells(46, 4), .Cells(48, 1), .Cells(48, 2), .Cells(48, 3), .Cells(48, 4), .Cells(50, 1), .Cells(50, 2), .Cells(50, 3), .Cells(50, 4), .Cells(52, 4), .Cells(3, 2), .Cells(4, 2)
                ElseIf .Name Like "*sheetc*" Then
                    AppendRow wkb2.Worksheets("sheetc"), .Cells(9, 1), .Cells(9, 3), .Cells(9, 2), .Cells(23, 1), .Cells(19, 2), .Cells(19, 3), .Cells(13, 1), .Cells(13, 2), .Cells(33, 1), .Cells(33, 2), .Cells(33, 3), .Cells(33, 4), .Cells(35, 1), .Cells(35, 2), .Cells(35, 3), .Cells(35, 4), .Cells(37, 1), .Cells(37, 2), .Cells(37, 3), .Cells(37, 4), .Cells(39, 4), .Cells(3, 2), .Cells(4, 2)
                ElseIf .Name Like "*sheetd*" Then
                    AppendRow wkb2.Worksheets("sheetd"), .Cells(9, 1), .Cells(9, 2), .Cells(9, 4), .Cells(13, 1), .Cells(13, 2), .Cells(13, 3), .Cells(21, 1), .Cells(17, 1), .Cells(17, 2), .Cells(17, 3), .Cells(3, 2), .Cells(4, 2)
                ElseIf .Name Like "*sheetf*" Then
                    AppendRow wkb2.Worksheets("Sheetf"), .Cells(9, 1), .Cells(9, 2), .Cells(9, 3), .Cells(11, 1), .Cells(15, 2), .Cells(15, 3), .Cells(3, 2), .Cells(4, 2)
                End If
            End If
        End With
    Next
    ToggleEvents True
End Sub