Speed up Slow VBA

B

Biz

Well-known Member
Joined
May 18, 2009
Messages
1,773
Office Version
  1. 2021
Platform
  1. Windows
Hi Guys,

I most have over looked sometime because my vba is very slow.
Using Excel 2003.

Any suggestions would be appreciated.

Code: 
Sub UpdateRecords()
    Dim AWb As Workbook
    Dim LastRow As Long
    Dim ws As Worksheet
    Dim wsTarget As Worksheet, wsDestination As Worksheet
    Dim aRecordsReturned As Boolean
    Dim LR As Long
    Dim GLCode As Range, Quantity As Range, Amount As Range, Vendor As Range, _
        JGLCode As Range, JQuantity As Range, JAmount As Range, JVendor As Range, _
        rCell As Range, LDelete As Range, aRow As Range
 
    'Speeding Up VBA Code
    Application.ScreenUpdating = False 'Prevent screen flickering
    Application.Calculation = xlCalculationManual 'Preventing calculation
    Application.DisplayAlerts = False 'Turn OFF alerts
    Application.EnableEvents = False 'Prevent All Events
 
     Set AWb = ActiveWorkbook
    Application.Calculation = xlAutomatic 'Set Workbook at Auto Cal
 
    If uSheetExists("Internal Charges") Then
        Sheets("Internal Charges").Delete
    End If
 
    'Internal Charges Sheet exist before Renaming
        Sheets("Original Report (Don't Touch)").Copy Before:=Sheets(1)
        Sheets("Original Report (Don't Touc (2)").Name = "Internal Charges"
 
    Set ws = Sheets("Internal Charges")
   'Last Row ws
    LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
 
    'Formating, Deletion and add additional fields
    Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove ' Add Two Rows
    Rows("4:5").Delete Shift:=xlUp 'Delete rows 4 & 5
 
    'Autofilter Excluding RI and then Delete
    Sheets("Internal Charges").Range("A3:AA" & LastRow).AutoFilter Field:=7, Criteria1:="<>RI", _
        Operator:=xlAnd
    ws.Range("A3:AA" & LastRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    'ShowAllRecords
    Call ShowAllRecords
 
    'Insert Two columns
    ws.Columns("B:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    'Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    ws.Range("A4:A" & LastRow).Select
 
    'Text to Columns
    Selection.TextToColumns Destination:=Range("A4"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=".", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
        TrailingMinusNumbers:=True
 
    'If uSheetExists("Job") Then
        'Sheets("Job").Delete
    'End If
 
    'Active Job list
    'Workbooks.Open Filename:="G:\General\Job Book\Jobs Book 380(AMA).xls", ReadOnly:=True
    'Sheets("Job").Copy After:=AWb.Sheets(3)
    'Sheets("Job").Shapes("Button 1").Cut
 
   'Workbooks("Jobs Book 380(AMA).xls").Close savechanges:=False
 
    'Define New Column Names
    ws.Range("B3") = "Sub1"
    ws.Range("C3") = "Sub2"
    ws.Range("P3") = "380 Dept/Job #"
    ws.Range("Q3") = "G/L Code"
    ws.Range("R3") = "Units"
    ws.Range("S1") = "S. Batch:"
    ws.Range("S2") = "Journal:"
    ws.Range("S3") = "Amount"
    ws.Range("T3") = "Description"
    ws.Range("X3") = "G/L Code"
    ws.Range("Y3") = "Amount"
    ws.Range("AA3") = "Original G/L"
 
    'Shading in Yellow
    ws.Range("T1:T2").Interior.ColorIndex = 6 'Yellow for input cells
 
    'Remove auto filter
    ws.Range("A3:AA" & LastRow).AutoFilter
 
    'Define Formulas
    ws.Range("P4").FormulaR1C1 = _
        "=IF(ISERROR(MATCH(RC1,Job!C[-14],0)),""Please Check!!!"",INDEX(Job!C[-15],MATCH(RC1,Job!C[-14],0)))"
    ws.Range("Q4").FormulaR1C1 = "=CONCATENATE(RC[-1],""."",RC[-15],""."",RC[-14])"
    ws.Range("R4").FormulaR1C1 = "=RC[-8]"
    ws.Range("S4").FormulaR1C1 = "=RC[-7]*1.109"
    ws.Range("T4").FormulaR1C1 = "=RC[-14]"
    ws.Range("X4").FormulaR1C1 = "=RC[-23]&"".4010"""
    ws.Range("Y4").FormulaR1C1 = "=-RC[-13]"
    ws.Range("AA4").FormulaR1C1 = "=CONCATENATE(RC[-26],""."",RC[-25],""."",RC[-24])"
 
    'Autocopy formulas
    ws.Range("P4").Copy ws.Range("P4:P" & LastRow)
    ws.Range("Q4").Copy ws.Range("Q4:Q" & LastRow)
    ws.Range("R4").Copy ws.Range("R4:R" & LastRow)
    ws.Range("S4").Copy ws.Range("S4:S" & LastRow)
    ws.Range("T4").Copy ws.Range("T4:T" & LastRow)
    ws.Range("X4").Copy ws.Range("X4:X" & LastRow)
    ws.Range("Y4").Copy ws.Range("Y4:Y" & LastRow)
    ws.Range("AA4").Copy ws.Range("AA4:AA" & LastRow)
 
    ws.Cells.EntireColumn.AutoFit
 
    'Sort on Internal Charges Sheet
    ws.Activate
 
    With Range("A3:AA" & LastRow)
 
           .Sort Key1:=Range("B3"), _
                 Order1:=xlAscending, _
                 Header:=xlYes, _
                 MatchCase:=False, _
                 Orientation:=xlTopToBottom
 
           .Sort Key1:=Range("C3"), _
                 Order1:=xlAscending, _
                 Header:=xlYes, _
                 MatchCase:=False, _
                 Orientation:=xlTopToBottom
 
    End With
 
 
    'Delete Codes < 5000 = Revenue Codes
    ws.Range("A3:AA" & LastRow).AutoFilter Field:=2, Criteria1:="<5000", _
        Operator:=xlAnd
    Range("A3:AA" & LastRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    ws.Range("A3:AA" & LastRow).AutoFilter Field:=2 'Remove filters from Row 2
 
    If uSheetExists("Journal") Then
        Sheets("Journal").Delete
    End If
'Add a sheet called "UniqueList"
        Worksheets.Add().Name = "Journal"
'For Each rCell In aSheetList
    Set wsTarget = Worksheets("Internal Charges")
    Set wsDestination = Worksheets("Journal")
'ShowAllRecords
    Call ShowAllRecords
    LR = wsTarget.Cells(Rows.Count, "a").End(xlUp).Row
'Look for Limb2
'Check if cost code is 29101 then ok otherwise do journal
    wsTarget.Range("A3:AA" & LR).AutoFilter Field:=3, Criteria1:="=69285" 'Find Limb 2 Sub2 69285
    wsTarget.Range("A3:AA" & LR).AutoFilter Field:=1, Criteria1:="<>29101" 'Find Limb 2 Cost 29101 gives Journals
'Formatting
    wsTarget.Range("A3").Copy
    wsDestination.Range("A1:D1").PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
'Define New Column Names
    wsDestination.Range("A1") = "G/L Code"
    wsDestination.Range("B1") = "Quantity"
    wsDestination.Range("C1") = "Amount"
    wsDestination.Range("D1") = "Vendor"
    wsDestination.Range("Z1") = "Reverse Signs"
    wsDestination.Range("Z2").Value = -1
 
If FilteredRowsCount(wsTarget) > 0 Then
 
'Copy Visible Cells
    Set GLCode = wsTarget.Range("AA4:AA" & LR).SpecialCells(xlCellTypeVisible)
    Set Quantity = wsTarget.Range("J4:J" & LR).SpecialCells(xlCellTypeVisible)
    Set Amount = wsTarget.Range("L4:L" & LR).SpecialCells(xlCellTypeVisible)
    Set Vendor = wsTarget.Range("E4:E" & LR).SpecialCells(xlCellTypeVisible)
'Paste to Journal Side A
    Set JGLCode = wsDestination.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Set JQuantity = wsDestination.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
    Set JAmount = wsDestination.Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
    Set JVendor = wsDestination.Range("D" & Rows.Count).End(xlUp).Offset(1, 0)
' Reverse Signs by -1 Side A
 
    GLCode.Copy
        JGLCode.PasteSpecial Paste:=xlPasteValues
    Quantity.Copy
        JQuantity.PasteSpecial Paste:=xlPasteValues
            wsDestination.Range("Z2").Copy
        Range(JQuantity, JQuantity.End(xlDown)).PasteSpecial Operation:=xlPasteSpecialOperationMultiply
    Amount.Copy
        JAmount.PasteSpecial Paste:=xlPasteValues
            wsDestination.Range("Z2").Copy
        Range(JAmount, JAmount.End(xlDown)).PasteSpecial Operation:=xlPasteSpecialOperationMultiply
    Vendor.Copy
        JVendor.PasteSpecial Paste:=xlPasteValues
 
   wsDestination.Cells.EntireColumn.AutoFit
 
 End If
 
  'Code to check if records returned
If FilteredRowsCount(wsTarget) > 0 Then
 
wsTarget.Range("A3:AA" & LR).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
 'Paste Journal Side B
 'Need To work on This soon!!!!
 
 
'ShowAllRecords
Call ShowAllRecords
wsTarget.Range("A3:AA" & LR).AutoFilter Field:=3, Criteria1:="=69285" 'Find Limb 2 Sub2 69285
 
    If FilteredRowsCount(wsTarget) > 0 Then
        wsTarget.Range("A3:AA" & LR).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete 'Filter, offset(to exclude headers) and delete visible rows Limb 2
    End If
 
'ShowAllRecords
Call ShowAllRecords
'Hide Limb 1 and Search for Limb 2
wsTarget.Range("A3:AA" & LR).AutoFilter Field:=3, Criteria1:="<>69284" 'Find <> Limb 1 Sub2 69284
 wsTarget.Range("A3:AA" & LR).AutoFilter Field:=6, Criteria1:= _
        "=**Limb2**", Operator:=xlOr, Criteria2:="=**Limb?2**" 'Find Limb2,Limb 2,Lim_2
'Check out??????
If FilteredRowsCount(wsTarget) > 0 Then
 
'Copy Visible Cells
    Set GLCode = wsTarget.Range("AA4:AA" & LR).SpecialCells(xlCellTypeVisible)
    Set Quantity = wsTarget.Range("J4:J" & LR).SpecialCells(xlCellTypeVisible)
    Set Amount = wsTarget.Range("L4:L" & LR).SpecialCells(xlCellTypeVisible)
    Set Vendor = wsTarget.Range("E4:E" & LR).SpecialCells(xlCellTypeVisible)
'Paste to Journal Side A
    Set JGLCode = wsDestination.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Set JQuantity = wsDestination.Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
    Set JAmount = wsDestination.Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
    Set JVendor = wsDestination.Range("D" & Rows.Count).End(xlUp).Offset(1, 0)
' Reverse Signs by -1 Side A
 
    GLCode.Copy
        JGLCode.PasteSpecial Paste:=xlPasteValues
    Quantity.Copy
        JQuantity.PasteSpecial Paste:=xlPasteValues
            wsDestination.Range("Z2").Copy
        Range(JQuantity, JQuantity.End(xlDown)).PasteSpecial Operation:=xlPasteSpecialOperationMultiply
    Amount.Copy
        JAmount.PasteSpecial Paste:=xlPasteValues
            wsDestination.Range("Z2").Copy
        Range(JAmount, JAmount.End(xlDown)).PasteSpecial Operation:=xlPasteSpecialOperationMultiply
    Vendor.Copy
        JVendor.PasteSpecial Paste:=xlPasteValues
 
   wsDestination.Cells.EntireColumn.AutoFit
 
   wsTarget.Range("A3:AA" & LR).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete '????Filter, offset(to exclude headers) and delete visible rows Limb 2
 End If
 
'ShowAllRecords
Call ShowAllRecords
 
'Filter, Find and Replace Codes
wsTarget.Range("A3:AA" & LR).AutoFilter Field:=3, Criteria1:="=69284" 'Find Limb 1 Sub2 69284
    If FilteredRowsCount(wsTarget) > 0 Then
        wsTarget.Range("C3:C" & LR).Offset(1, 0).SpecialCells (xlCellTypeVisible) 'change 69284 to 94000
        'On Error Resume Next
        Selection.Replace What:="69284", Replacement:="94000", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
        wsTarget.Range("B3:B" & LR).Offset(1, 0).SpecialCells (xlCellTypeVisible) 'change 6080 to 94000
        Selection.Replace What:="6080", Replacement:="9400", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
    End If
 
'ShowAllRecords
Call ShowAllRecords
'Define New Column Names
    wsTarget.Range("AD1") = "Delete Codes"
    wsTarget.Range("AD2").Value = 90300
    wsTarget.Range("AE2").Value = 90400
    wsTarget.Range("AF2").Value = 90500
    wsTarget.Range("AG2").Value = 90600
    wsTarget.Range("AH2").Value = 90700
    wsTarget.Range("AI2").Value = 90800
 
wsTarget.Activate
 
Set LDelete = wsTarget.Range(Range("AD2"), Range("AD2").End(xlToRight))
  'Looping Unique Delete List through Autofilter
    For Each rCell In LDelete
 
 
            wsTarget.Range("A3:AA" & LR).AutoFilter Field:=3, Criteria1:=rCell
 
            'Code to check if records returned
           If FilteredRowsCount(wsTarget) > 0 Then
 
               wsTarget.Range("A3:AA" & LR).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            End If
            Call ShowAllRecords
         'End If
    Next rCell
Call ShowAllRecords
 
    'Remove All Speeding Up VBA Code
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True 'Alerts back ON
    Application.EnableEvents = True
 
'Finish off at Internal Charges
     Application.GoTo wsTarget.Range("A1"), True
 
    MsgBox "Process Completed!"
 
 
End Sub
 
    'Returns True if sheet existss
Function uSheetExists(aSheetName, Optional aWorkbook)
    Dim aWorksheet
    uSheetExists = False
    If IsMissing(aWorkbook) Then Set aWorkbook = Application.ActiveWorkbook
    On Error Resume Next
    For Each aWorksheet In aWorkbook.Worksheets
        If UCase(aWorksheet.Name) = UCase(aSheetName) Then uSheetExists = True
    Next aWorksheet
End Function
Function FilteredRowsCount(ByVal Sh As Worksheet)
    Dim Target As Range
    Dim c As Range
    Dim i As Long
    'If the Filter is not used
    If Sh.FilterMode = False Then
        FilteredRowsCount = 0
        Exit Function
    End If
    Set Target = Sh.AutoFilter.Range
    For Each c In Target.SpecialCells(xlCellTypeVisible).Areas
        i = i + c.Rows.Count
    Next
    FilteredRowsCount = i - 1    '-1 stands for remove header row
End Function
Sub ShowAllRecords()
Dim wsTarget As Worksheet
Set wsTarget = Worksheets("Internal Charges")
If wsTarget.FilterMode Then
    wsTarget.ShowAllData
End If
End Sub

Biz
 
Sort by date Sort by votes
Why do you set calculations to manual, then a few lines later set them back to automatic?

That's the first thing that jumps out that might affect speed.

There are some other things in the code that might do with a fix but I'm not sure if they would speed things up.

One of those is using Selection - you should try and avoid that if possible.

Also you seem to be referencing things OK sometimes but not others.

For example here you use ws to reference the worksheet for the filter, but not for the delete.
Code: 
 ws.Range("A3:AA" & LastRow).AutoFilter Field:=2, Criteria1:="<5000", _
        Operator:=xlAnd
    Range("A3:AA" & LastRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Another thing is that you seem to be calling ShowAllRecords quite a bit - is that definitely needed?:)
 
Upvote 0
Hmmm...haven't looked at the code in a huge amount of detail. But often changes in logic are more effective than changes in coding per se. You appear, for instance, to run a sequence like

a] filter a range by Criteria 1
b] delete the visible rows
c] sort
d] filter by something else
e] delete the visible rows

It may be that you can condense this into 3 quicker steps:

a] filter by Criteria 1 OR Criteria 2
b] set the visible cells' values = vbNullString (which will be quicker than deleting rows)
b] sort (in the process bunching together the empty rows)

Of course it may turn out this won't work; you're probably best placed to tell...
 
Upvote 0
You could get rid of the three functions
  • uSheetExists
  • FilteredRowsCount
  • ShowAllRecords

For uSheetExists, replace in your code this...
Code: 
    If uSheetExists("Internal Charges") Then
        Sheets("Internal Charges").Delete
    End If
With this...
Code: 
    On Error Resume Next
        AWb.Sheets("Internal Charges").Delete
    On Error GoTo 0

----
For FilteredRowsCount, replace in your code this...
Code: 
If FilteredRowsCount(wsTarget) > 0 Then
With this...
Code: 
If wsTarget.Range("A3:AA" & LastRow).SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then

I think the function FilteredRowsCount can be particularly slow if you have a lot of rows.

----
For ShowAllRecords, replace in your code this...
Code: 
Call ShowAllRecords
With this...
Code: 
ws.AutofilterMode = False
 
Upvote 0
Hi All,

At home it take 3mins and I spent an hour debugging it and when I ran it at work it took 7secs.The same code at home take 3mins and at work 7secs.

I think I may have problems with RAM or spyware issues in my home computure. It is Dual core with 2gb ram running Excel 2003.
At work running Excel 2007 2Quad.

Thank you for everyone on there feedback and like ways remove UDF functions.

Biz
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
VBA Copy/Paste New Data Only
Replies
0
Views
485
ah2024_2024
A
O
  • Question Question
User-defined type not defined - vba/excel error
Replies
4
Views
430
RoryA
RoryA
J
  • Question Question
VBA removing heading in spreadsheet
Replies
3
Views
311
rlv01
R
V
  • Solved
Need VBA to split data into multiple sheets paste formulas, formatting AND data validation
Replies
2
Views
265
vanessavalentino83
V
S
  • Solved
Copy values only without specific column formats VBA
Replies
9
Views
455
sofas
S

Share this page

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