asked on

Code efficiency - Help speeding things up. Excel VBA

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

ASKER CERTIFIED SOLUTION

Rory Archibald

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

SOLUTION

Chris Bottomley

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Rowan Scott

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 = ""

Rory Archibald

Cells(r, 1).Value = ""
will match a blank cell, BTW.

Rowan Scott

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.

jasocke2

ASKER

@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 Bottomley

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

Chris