Performance of VBA

[Mike_VBA]

Hi Everyone!

Happy New Year!

I am trying to make my VBA faster - It is pretty slow for now (30 secs)

<style type="text/css">p.p1 {margin: 0.0px 0.0px 0.0px 0.0px; font: 12.0px 'Helvetica Neue'}p.p2 {margin: 0.0px 0.0px 0.0px 0.0px; font: 12.0px 'Helvetica Neue'; min-height: 14.0px}</style>Function GetWorksheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetWorksheet = Worksheets(shtName)
End Function
Sub recon()
    Dim i As Long
    i = 2
    'To search for additional sheet created in previous run and delete it
    For Each ws In Worksheets
    If ws.Name = "RECONCILE" Then
        Application.DisplayAlerts = False
        Sheets("RECONCILE").Delete
        Application.DisplayAlerts = True
    End If
    'Delete sheet from finance if it exists
    If Not GetWorksheet("Working") Is Nothing Then
    Application.DisplayAlerts = False
    Sheets("Working").Delete
    Application.DisplayAlerts = True
    End If
    Next
    Worksheets("CBS").Columns(11).NumberFormat = "0"
    Worksheets("CBS").Range("A1").AutoFilter Field:=2, Criteria1:="M2URPN"
    If Worksheets("M2URPN").Range("A1") = "1MAYBANK" Then
    Worksheets("M2URPN").Rows("1:3").EntireRow.Delete
    End If
    Sheets("M2URPN").Select
    Do While i <= ThisWorkbook.ActiveSheet.Range("A2").CurrentRegion.Rows.Count
        If InStr(1, ThisWorkbook.ActiveSheet.Cells(i, 1).Text, "1MAYBANK", vbTextCompare) > 0 Or _
        InStr(1, ThisWorkbook.ActiveSheet.Cells(i, 1).Text, "DEPT", vbTextCompare) > 0 Or _
        InStr(1, ThisWorkbook.ActiveSheet.Cells(i, 1).Text, "0PAYEE", vbTextCompare) > 0 Or _
        InStr(1, ThisWorkbook.ActiveSheet.Cells(i, 1).Text, "0NAME", vbTextCompare) > 0 Then
            ThisWorkbook.ActiveSheet.Cells(i, 1).EntireRow.Delete
        Else
            i = i + 1
        End If
    Loop
    Worksheets("M2URPN").Columns(4).NumberFormat = "0"
    If Worksheets("M2URPN").Cells(Rows.Count, 1).End(xlUp).Value = "-*** END OF REPORT ***" Then
    With Worksheets("M2URPN")
        .Cells(Rows.Count, "A").End(xlUp). _
        Offset(-34).Resize(35).EntireRow.Delete
    End With
    End If
    Worksheets("CBS").Range("K:K").Copy Destination:=Worksheets("M2URPN").Range("H1")
    Worksheets("CBS").Range("R:R").Copy Destination:=Worksheets("M2URPN").Range("I1")
    Worksheets("CBS").Range("Q:Q").Copy Destination:=Worksheets("M2URPN").Range("J1")
    Worksheets("M2URPN").Range("G2").FormulaR1C1 = "Type"
    Worksheets("CBS").Columns("A:Z").AutoFit
    Worksheets("M2URPN").Columns("A:Z").AutoFit
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "RECONCILE"
    Call M2UMissing
'    Call CBSMissing
    MsgBox "Data Magic for Amelia is Done"
End Sub


Sub M2UMissing()


Dim i As Long, _
LRa As Long, _
LRb As Long, _
rowx As Long
LRa = Range("I" & Rows.Count).End(xlUp).Row
LRb = Range("F" & Rows.Count).End(xlUp).Row
rowx = 2
Application.ScreenUpdating = False
For i = 2 To LRa
If IsError(Application.Match(Range("I" & i).Value, Range("F2:F" & LRb), 0)) Then
Range("O" & rowx).Value = Range("F" & i).Value
rowx = rowx + 1
End If
Next i
rowx = 2
For i = 2 To LRb
If IsError(Application.Match(Range("F" & i).Value, Range("I2:I" & LRa), 0)) Then
Range("S" & rowx).Value = Range("I" & i).Value
rowx = rowx + 1
End If
Next i
Worksheets("M2URPN").Range("O1") = "MISSING IN CBS"
Worksheets("M2URPN").Range("S1") = "MISSING IN M2U"
Sheets("M2URPN").Columns(15).Cut Destination:=Sheets("RECONCILE").Columns(1)
Sheets("M2URPN").Columns(19).Cut Destination:=Sheets("RECONCILE").Columns(5)
Application.ScreenUpdating = True
End Sub
Sub ssss()
'Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
Application.ScreenUpdating = False
Columns(6).Cut
Columns(1).Insert Shift:=xlToRight
Columns(9).Cut
Columns(8).Insert Shift:=xlToRight
Application.ScreenUpdating = True
End Sub
[FONT=Verdana]

If anyone can help me on how Im approaching my loops Ill be grateful![/FONT]

 

[dmt32]

Hi,
untested but see if this vain attempt to update your code does what you want

Sub recon()
    Dim i As Long
    Dim ws As Worksheet, wsCBS As Worksheet, wsM2URPN As Worksheet
    Dim DeleteRange As Range
    
    i = 2
    With Application
        .DisplayAlerts = False: .ScreenUpdating = False: .Calculation = xlCalculationManual: .EnableEvents = False
    End With
    
    On Error Resume Next
     With ThisWorkbook
        .Worksheets("RECONCILE").Delete
        .Worksheets("Working").Delete
      End With
    
    On Error GoTo myerror
    
    With ThisWorkbook
        Set wsCBS = .Worksheets("CBS")
        Set wsM2URPN = .Worksheets("M2URPN")
    End With
    
    With wsCBS
        .Columns(11).NumberFormat = "0"
        .Range("A1").AutoFilter Field:=2, Criteria1:="M2URPN"
    End With
    
    If wsM2URPN.Range("A1") = "1MAYBANK" Then wsM2URPN.Rows("1:3").EntireRow.Delete


    With wsM2URPN
    
    Do While i <= .Range("A2").CurrentRegion.Rows.Count
        If InStr(1, .Cells(i, 1).Text, "1MAYBANK", vbTextCompare) > 0 Or _
        InStr(1, .Cells(i, 1).Text, "DEPT", vbTextCompare) > 0 Or _
        InStr(1, .Cells(i, 1).Text, "0PAYEE", vbTextCompare) > 0 Or _
        InStr(1, .Cells(i, 1).Text, "0NAME", vbTextCompare) > 0 Then
            If DeleteRange Is Nothing Then
                Set DeleteRange = .Cells(i, 1)
            Else
                Set DeleteRange = Union(DeleteRange, .Cells(i, 1))
            End If
        End If
        i = i + 1
    Loop
    
'delete ranges in one go
        If Not DeleteRange Is Nothing Then DeleteRange.EntireRow.Delete
        
        .Columns(4).NumberFormat = "0"
    If .Cells(.Rows.Count, 1).End(xlUp).Value = "-*** END OF REPORT ***" Then
        .Cells(.Rows.Count, "A").End(xlUp).Offset(-34).Resize(35).EntireRow.Delete
    End If
    End With
    
    With wsCBS
        .Range("K:K").Copy Destination:=wsM2URPN.Range("H1")
        .Range("R:R").Copy Destination:=wsM2URPN.Range("I1")
        .Range("Q:Q").Copy Destination:=wsM2URPN.Range("J1")
        .Range("G2").FormulaR1C1 = "Type"
        .Columns("A:Z").AutoFit
    End With
    
    wsM2URPN.Columns("A:Z").AutoFit
    
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "RECONCILE"
    Call M2UMissing
'    Call CBSMissing


myerror:
    If Err <> 0 Then
        MsgBox (Error(Err)), 48, "Error"
    Else
        MsgBox "Data Magic for Amelia is Done", 64, "All Done"
    End If
    
    Set DeleteRange = Nothing
    With Application
        .DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True
    End With
End Sub

As always, make a back-up of your workbook BEFORE testing new code.

Dave

 

[Michael M]

I'd also try to avoid referring to entire columns

Worksheets("CBS").Range("K:K").Copy Destination:=Worksheets("M2URPN").Range("H1")
    Worksheets("CBS").Range("R:R").Copy Destination:=Worksheets("M2URPN").Range("I1")
    Worksheets("CBS").Range("Q:Q").Copy Destination:=Worksheets("M2URPN").Range("J1")

Even if you restrict it to a set number

With wsCBS
        .Range("K1:K1000").Copy Destination:=wsM2URPN.Range("H1")
        .Range("R1:R1000").Copy Destination:=wsM2URPN.Range("I1")
        .Range("Q1:Q1000").Copy Destination:=wsM2URPN.Range("J1")
        .Range("G2").value= "Type"
        .Columns("A:Z").AutoFit
End With

 

[Mike_VBA]

Thanks @dmt32!

It doesnt speeden up things but is way cleaner. Thanks for the help!