Iron Man February 2016

RT-1004 when copying data from destination to Source workbooks

I use this code to copy data from a workbook that is an import from a report. However, as the month progresses and the amount of data grows, so does the amount of time to run this sub (in the last week of January it took 3 minutes to process 900 rows of data):

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
        

Answers


Fadi February 2016

Try this code (on temp copy of your workbooks):

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:=x 

Post Status

Asked in February 2016
Viewed 3,421 times
Voted 12
Answered 1 times

Search




Leave an answer