RT-1004 при копировании данных из места назначения в исходные рабочие книги

Я использую этот код для копирования данных из книги, которая импортируется из отчета. Тем не менее, с течением месяца и увеличением объема данных увеличивается и время запуска этой подпрограммы (в последнюю неделю января потребовалось 3 минуты для обработки 900 строк данных):

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

Но сейчас есть

Ошибка времени выполнения "1004": ошибка приложения или объекта

для этой строки:

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
Источник

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
Источник
Другие вопросы по тегам