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

时间：2016-10-02 03:45:04

标签： excel vba excel-vba

任何帮助都将在此

中受到赞赏

我有以下代码，它通过工作簿1查看具有特定名称的工作表（例如，SheetA，Sheetb等）。在工作表匹配后，如果某个标准在选择工作表上匹配，它将从工作簿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

1 个答案:

答案 0 :(得分：3)

关闭Application.Calculations，通过使用数组来消除选择和减少写入次数将加快代码的速度。

JSON
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
相关问题
最新问题