Question

我使用此代码从工作簿中复制数据，该工作簿是从报表导入的。但是，随着月份的进展和数据量的增加，运行此子服务的时间也会增加（在1月的最后一周，处理900行数据需要3分钟）：

Sub Extract_Sort_1602_February()

Dim ANS As Long

ANS = MsgBox("Is the February 2016 Swivel Master File checked out of SharePoint and currently open on this desktop?", vbYesNo + vbQuestion + vbDefaultButton1, "Master File Open")
If ANS = vbNo Or IsWBOpen("Swivel - Master - February 2016") = False Then
    MsgBox "The required workbook is not currently open. This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
    Exit Sub
End If

Application.ScreenUpdating = False

    ' This line autofits the columns C, D, O, and P
    Range("C:C,D:D,O:O,P:P").Columns.AutoFit

    ' This unhides any hidden rows
    Cells.EntireRow.Hidden = False

Dim LR As Long

    For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("B" & LR).Value <> "2" Then
            Rows(LR).EntireRow.Delete
        End If
    Next LR

Application.Run "'Swivel - Master - February 2016.xlsm'!Unfilter"

With ActiveWorkbook.Worksheets("Extract").Sort
    With .SortFields
        .Clear
        .Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("D2:D2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("O2:O2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("J2:J2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("K2:K2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add Key:=Range("L2:L2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End With
    .SetRange Range("A2:AE2000")
    .Apply
End With
Cells.WrapText = False
Sheets("Extract").Range("A2").Select

    Dim LastRow As Integer, i As Integer, erow As Integer

    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To LastRow
        If Cells(i, 2) = "2" Then

            ' As opposed to selecting the cells, this will copy them directly
            Range(Cells(i, 1), Cells(i, 31)).Copy

            ' As opposed to "Activating" the workbook, and selecting the sheet, this will paste the cells directly
            With Workbooks("Swivel - Master - February 2016.xlsm").Sheets("Swivel")
                erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                .Cells(erow, 1).PasteSpecial xlPasteAll
            End With
            Application.CutCopyMode = False
        End If
    Next i

Application.ScreenUpdating = True
End Sub

我在Code Review中提出了一种更有效的方法来实现预期的结果，并提出了这个问题：

Sub Extract_Sort_1602_February()

Dim ANS As Long

ANS = MsgBox("Is the February 2016 Swivel Master File checked out of SharePoint and currently open on this desktop?", vbYesNo + vbQuestion + vbDefaultButton1, "Master File Open")
If ANS = vbNo Or IsWBOpen("Swivel - Master - February 2016") = False Then
    MsgBox "The required workbook is not currently open. This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
    Exit Sub
End If

Application.ScreenUpdating = False

    ' This line autofits the columns C, D, O, and P
    Range("C:C,D:D,O:O,P:P").Columns.AutoFit

    ' This unhides any hidden rows
    Cells.EntireRow.Hidden = False

Dim LR As Long

    For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("B" & LR).Value <> "2" Then
            Rows(LR).EntireRow.Delete
        End If
    Next LR

Application.Run "'Swivel - Master - February 2016.xlsm'!Unfilter"

   With sourceWorksheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("D2:D2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("O2:O2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("J2:J2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("K2:K2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("L2:L2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange Range("A2:AE2000")
        .Apply
    End With
Cells.WrapText = False
Sheets("Extract").Range("A2").Select

Dim sourceWorkBook As Workbook
Set sourceWorkBook = Workbooks("TEMPIMPORT.xlsx")
Dim destinationWorkbook As Workbook
Set destinationWorkbook = Workbooks("Swivel - Master - February 2016.xlsm")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkBook.Sheets("Extract")
Dim destinationWorksheet As Worksheet
Set destinationWorksheet = destinationWorkbook.Sheets("Swivel")
Dim lastRow As Integer
lastRow = sourceWorksheet.Range("A" & Rows.Count).End(xlUp).Row
Dim sourceRow As Integer
Dim destinationRow As Integer
destinationRow = destinationWorksheet.Cells(Rows.Count, 1).End(xlUp) + 1


For sourceRow = 2 To lastRow
    If Cells(sourceRow, 2) = "2" Then
        destinationWorksheet.Rows(destinationRow) = sourceWorksheet.Rows(sourceRow) ' This is where the Run-Time error occurs
        destinationRow = destinationRow + 1
    End If
Next sourceRow

Call ExtractSave

Application.ScreenUpdating = True
End Sub

但现在有一个

运行时错误＆＃39; 1004＆＃39;：应用程序定义或对象定义的错误

这一行：

destinationWorksheet.Rows(destinationRow) = sourceWorksheet.Rows(sourceRow)

我已经包含了源数据和目标工作簿的两个快照。

此子用于在复制/粘贴之前清除所有过滤器。

Sub Unfilter()

Dim she As Variant
For Each she In ThisWorkbook.Worksheets
    If she.FilterMode Then she.ShowAllData
Next

End Sub

Answer 1

尝试此代码（在工作簿的临时副本上）：

Sub Extract_Sort_1602_February()

Dim ANS As Long
Dim LR As Long
Dim uRng As Range
Dim she As Worksheet

 ANS = MsgBox("Is the February 2016 Swivel Master File checked out of SharePoint and currently open on this desktop?", vbYesNo + vbQuestion + vbDefaultButton1, "Master File Open")
 If ANS = vbNo Or IsWBOpen("Swivel - Master - February 2016") = False Then
     MsgBox "The required workbook is not currently open. This procedure will now terminate.", vbOKOnly + vbExclamation, "Terminate Procedure"
     Exit Sub
 End If

Dim sourceWorkBook As Workbook
 Set sourceWorkBook = Workbooks("TEMPIMPORT.xlsx")
Dim destinationWorkbook As Workbook
 Set destinationWorkbook = Workbooks("Swivel - Master - February 2016.xlsm")
Dim sourceWorksheet As Worksheet
 Set sourceWorksheet = sourceWorkBook.Sheets("Extract")
Dim destinationWorksheet As Worksheet
 Set destinationWorksheet = destinationWorkbook.Sheets("Swivel")


Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

    ' This line autofits the columns C, D, O, and P
    sourceWorksheet.Range("C:C,D:D,O:O,P:P").Columns.AutoFit

    ' This unhides any hidden rows
    sourceWorksheet.Cells.EntireRow.Hidden = False



    For LR = sourceWorksheet.Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If sourceWorksheet.Range("B" & LR).Value <> "2" Then
         If uRng Is Nothing Then
          Set uRng = sourceWorksheet.Rows(LR)
         Else
          Set uRng = Union(uRng, sourceWorksheet.Rows(LR))
         End If
        End If
    Next LR

    If Not uRng Is Nothing Then uRng.Delete

    'Application.Run "'Swivel - Master - February 2016.xlsm'!Unfilter"
    For Each she In destinationWorkbook.Worksheets
        If she.FilterMode Then she.ShowAllData
    Next



   With sourceWorksheet.Sort
        With .SortFields
            .Clear
            .Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("D2:D2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("O2:O2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("J2:J2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("K2:K2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=Range("L2:L2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange Range("A2:AE2000")
        .Apply
    End With

    sourceWorksheet.Cells.WrapText = False

    Dim lastRow As Integer
    lastRow = sourceWorksheet.Range("A" & Rows.Count).End(xlUp).Row
    'Dim sourceRow As Integer
    Dim destinationRow As Integer
    destinationRow = destinationWorksheet.Cells(Rows.Count, 1).End(xlUp).Row + 1


    sourceWorksheet.Range("A2:AA" & lastRow).Copy destinationWorksheet.Range("A" & destinationRow)

    'For sourceRow = 2 To lastRow
    '    If Cells(sourceRow, 2) = "2" Then
    '        destinationWorksheet.Rows(destinationRow) = sourceWorksheet.Rows(sourceRow) ' This is where the Run-Time error occurs
    '        destinationRow = destinationRow + 1
    '    End If
    'Next sourceRow

    Call ExtractSave

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

将数据从目标复制到源工作簿时的RT-1004

1 个答案: