Performance of VBA

Mike_VBA

Board Regular
Joined
Dec 27, 2008
Messages
70
Hi Everyone!

Happy New Year!

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

Code:
<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]
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Hi,
untested but see if this vain attempt to update your code does what you want

Code:
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
 
Upvote 0
I'd also try to avoid referring to entire columns

Code:
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

Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,992
Messages
6,175,834
Members
452,674
Latest member
psion2600

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top