Code efficiency - Help speeding things up. Excel VBA

jasocke2
jasocke2 used Ask the Experts™
on
Hi

I have the below code which runs fine however it runs quite slow.
The purpose of it is some reconciliation. I have tweaked it a little however it is still seems quite slow for what it is doing - I think it is the two loops which are taking the longest.

Is there anything else I can do to it to tidy it up and make it faster?

Many thanks,

Sub Recon()
Application.ScreenUpdating = False
Sheets(ActiveSheetName).Activate
    On Error Resume Next
    Sheets("tmp1").Delete
    Sheets("tmp2").Delete
    On Error GoTo 0
    
    Cells.Copy
    Sheets.Add
    ActiveSheet.Paste
    ActiveSheet.Name = "tmp1"
    
    Application.CutCopyMode = False
    
    Selection.rows.Ungroup
    Selection.Columns.Ungroup
    
    Columns("B:J").Delete Shift:=xlToLeft
    rows("2:7").Delete Shift:=xlUp
    rows("3:3").Delete Shift:=xlUp
    

    r = 3
    Do Until Cells(r, 1).Value = ""
    If Cells(r, 1).Value = "Skip" Then
    rows(r).EntireRow.Delete
    Else
    r = r + 1
    End If
    Loop
    
    rows("1:1").Select
    rows("1:1").Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    c = 5
    Do Until Cells(1, c).Value = ""
    If Cells(1, c).Value = "Skip" Then
    Columns(c).EntireColumn.Delete
    Else
    c = c + 1
    End If
    Loop
    
    Columns("C:D").Delete Shift:=xlToLeft
    Columns("A:A").Delete Shift:=xlToLeft
    rows("1:1").Delete Shift:=xlUp
    Cells(1, 1).Value = "Rec"
    
    With ActiveSheet
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    Columns(LastCol).Delete Shift:=xlToLeft
    
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Resize.Select

    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    
    Range("A1").Select
    Sheets.Add
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        
    On Error Resume Next
    Sheets("tmp2").Delete
    On Error GoTo 0
    ActiveSheet.Name = "tmp2"
    
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select

    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
    Sheets("Reconciliation").Select
    rows("120:226").Clear
    Sheets("tmp2").Select
    Selection.Copy
    Sheets("Reconciliation").Select
    Range("A120").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
    
    Range("B120").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 8
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 90
    End With
    
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("tmp1").Delete
    Sheets("tmp2").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").ColumnWidth = 3.43
    
Application.ScreenUpdating = True
End Sub

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Most Valuable Expert 2011
Top Expert 2011
Commented:
You could try the version below (I think it does the same thing as yours, but hopefully it's a bit faster). I suspect the whole process could be improved if we had the workbook and knew what you were doing specifically.
Sub Recon()
    Dim wksStart As Worksheet, wksReconciliation As Worksheet
    Dim wks1 As Worksheet, wks2 As Worksheet
    Dim rngDel As Range
    Dim r As Long, c As Long, LastCol As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    On Error Resume Next
    Sheets("tmp1").Delete
    Sheets("tmp2").Delete
    On Error GoTo 0
    
    Set wksStart = ActiveSheet
    Set wksReconciliation = Sheets("Reconciliation")
    Set wks1 = Sheets.Add
    wks1.Name = "tmp1"
    Set wks2 = Sheets.Add
    wks2.Name = "tmp2"
    wksStart.UsedRange.Copy wks1.Range("A1")
        
    With wks1
        .Rows.Ungroup
        .Columns.Ungroup
    
        .Columns("B:J").Delete Shift:=xlToLeft
        .Rows("2:7").Delete Shift:=xlUp
        .Rows("3:3").Delete Shift:=xlUp
    

        r = 3
        Do Until .Cells(r, 1).Value = ""
            If .Cells(r, 1).Value = "Skip" Then
                If rngDel Is Nothing Then
                    Set rngDel = .Cells(r, 1)
                Else
                    Set rngDel = Union(rngDel, .Cells(r, 1))
                End If
            Else
                r = r + 1
            End If
        Loop
        If Not rngDel Is Nothing Then
            rngDel.EntireRow.Delete
            Set rngDel = Nothing
        End If
    
        .Rows("1:1").Value = .Rows("1:1").Value

        c = 5
        Do Until .Cells(1, c).Value = ""
            If .Cells(1, c).Value = "Skip" Then
                If rngDel Is Nothing Then
                    Set rngDel = .Cells(1, c)
                Else
                    Set rngDel = Union(rngDel, .Cells(1, c))
                End If
            Else
                c = c + 1
            End If
        Loop
        If Not rngDel Is Nothing Then
            rngDel.EntireColumn.Delete
            Set rngDel = Nothing
        End If
        
    
        .Columns("C:D").Delete Shift:=xlToLeft
        .Columns("A:A").Delete Shift:=xlToLeft
        .Rows("1:1").Delete Shift:=xlUp
        .Cells(1, 1).Value = "Rec"
    
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        .Columns(LastCol).Delete Shift:=xlToLeft
    
        With .Range("A1").CurrentRegion
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, _
                            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                            DataOption1:=xlSortNormal
    
            .Copy wks2.Range("A1")
        End With
    End With
        
    wksReconciliation.Rows("120:226").Clear
    
    With wks2
        With .Range("A1").CurrentRegion
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                DataOption1:=xlSortNormal
            
            .Copy wksReconciliation.Range("A120")
        End With
    End With
    With wksReconciliation
        .PivotTables("PivotTable2").PivotCache.Refresh
        
        With .Range("B120", .Range("B120").End(xlToRight))
            With .Font
                .Name = "Arial"
                .FontStyle = "Regular"
                .Size = 8
                .Underline = xlUnderlineStyleNone
                .ColorIndex = xlAutomatic
            End With
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .WrapText = True
            .Orientation = 90
        End With
    End With
    Application.DisplayAlerts = False
    Sheets("tmp1").Delete
    Sheets("tmp2").Delete
    Application.DisplayAlerts = True
        
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").ColumnWidth = 3.43
    
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Open in new window

Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011
Commented:
The following uses the find feature to quickly pick up the required range so give it a try.

Chris
Sub Recon()
Dim rng As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
'Sheets(ActiveSheetName).Activate
    On Error Resume Next
    Sheets("tmp1").Delete
    Sheets("tmp2").Delete
    On Error GoTo 0
    
    Cells.Copy
    Sheets.Add
    ActiveSheet.Paste
    ActiveSheet.Name = "tmp1"
    
    Application.CutCopyMode = False
    
    Selection.Rows.Ungroup
    Selection.Columns.Ungroup
    
    Columns("B:J").Delete Shift:=xlToLeft
    Rows("2:7").Delete Shift:=xlUp
    Rows("3:3").Delete Shift:=xlUp
    

    Set rng = Intersect(ActiveSheet.UsedRange, Columns(1), Rows(3 & ":" & Rows.Count))
    If Not rng Is Nothing Then
        Set rng = findCells(rng, "Skip")
        If Not rng Is Nothing Then rng.EntireRow.Delete
    End If
    
    Rows("1:1").Select
    Rows("1:1").Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Rows(1), ActiveSheet.Range(ActiveSheet.Columns(5), ActiveSheet.Columns(ActiveSheet.Columns.Count)))
    If Not rng Is Nothing Then
        Set rng = findCells(rng, "Skip")
        If Not rng Is Nothing Then rng.EntireColumn.Delete
    End If
    
    
    Columns("C:D").Delete Shift:=xlToLeft
    Columns("A:A").Delete Shift:=xlToLeft
    Rows("1:1").Delete Shift:=xlUp
    Cells(1, 1).Value = "Rec"
    
    With ActiveSheet
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    Columns(LastCol).Delete Shift:=xlToLeft
    
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Resize.Select

    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    
    Range("A1").Select
    Sheets.Add
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        
    On Error Resume Next
    Sheets("tmp2").Delete
    On Error GoTo 0
    ActiveSheet.Name = "tmp2"
    
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select

    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
    Sheets("Reconciliation").Select
    Rows("120:226").Clear
    Sheets("tmp2").Select
    Selection.Copy
    Sheets("Reconciliation").Select
    Range("A120").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
    
    Range("B120").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 8
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 90
    End With
    
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("tmp1").Delete
    Sheets("tmp2").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").ColumnWidth = 3.43
    
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub


Function findCells(rng As Range, strFind As String) As Range
Dim cel As Range
Dim strFirstCell As String
    
    Set cel = rng.Find(what:=strFind, lookat:=xlWhole)
    If cel Is Nothing Then Exit Function
    If strFirstCell = "" Then strFirstCell = cel.Address
    Do
        If findCells Is Nothing Then
            Set findCells = cel
        Else
            Set findCells = Union(findCells, cel)
        End If
        Set cel = rng.Find(what:=strFind, lookat:=xlWhole, after:=cel)
    Loop Until strFirstCell = cel.Address

End Function

Open in new window

Browsing your code jasocke2, this does hit me

Do Until Cells(r, 1).Value = "" 

This probably runs to the end of the worksheet because you probably dont have an empty string in blank cells

Try

Do Until Cells(r, 1).Value = Empty

or

Do Until Cells(r, 1).Text = ""


11/26 Forrester Webinar: Savings for Enterprise

How can your organization benefit from savings just by replacing your legacy backup solutions with Acronis' #CyberProtection? Join Forrester's Joe Branca and Ryan Davis from Acronis live as they explain how you can too.

Most Valuable Expert 2011
Top Expert 2011

Commented:
Cells(r, 1).Value = ""
will match a blank cell, BTW.
Yep youre right rorya.  I didn't think it would but even if the cells number format is set to number it still works.  Ignore my earlier post. It wont help.

Maybe the delete is taking the time.  You could try a timer to see what is taking long.

eg
dim x as double
x=timer

some code here

debug.print timer - x

and monitor in the imediate window.

Author

Commented:
@chris_bottomley
I'm getting an error at this line:         Set rng = findCells(rng, "Skip")
sub or function not defined.

Thanks for all your comments - it is the looping which is taking the longest, I haveing a mess with your ideas and report back.

Thanks
Chris BottomleySoftware Quality Lead Engineer
Top Expert 2011

Commented:
Where did you put the code ... the function at the end needs to be in a normal code module.

Chris

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial