The below code took around 25 minutes to get to 10% complete on the first cycle, which if I did my math right, means I'm looking at more than 4 hours run time for it to get through it's first of two cycles. There are approximately 275,800 rows in this particular dataset, but the goal is to be able to use this code on both larger and smaller datasets.
How can I speed this up?
Sub Rebill()
'Project 202119
'***Progress Bar***********
Dim CurrentProgress As Double
Dim ProgressPercentage As Double
Dim BarWidth As Long
Dim TotalRows As Long
Dim H As Long
'***************************
'*****Timer*****************
Dim StartTime As Double
Dim MinutesElapsed As String
'***************************
Dim Denied As New Scripting.Dictionary
Dim Denied2 As New Scripting.Dictionary
Dim Paid As New Scripting.Dictionary
Dim DoubleBill As New Scripting.Dictionary
Dim Group As New Scripting.Dictionary
Dim Rebill As New Scripting.Dictionary
Dim Name As String
Dim DOS As String
Dim MyID As String
Dim TxProvider As String
Dim LineStatus As String
Dim Units As String
Dim gID As Integer
Dim rID As Integer
Range("A2").Select
gID = 0
rID = 0
'****Timer**********
StartTime = Timer
'*******************
'***Progress Bar*********
H = 2
TotalRows = Cells(Rows.Count, 3).End(xlUp).Row
Call InitProgressBar
'*************************
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'*********Assigning to Dictionaries***************
Do Until IsEmpty(ActiveCell)
Name = Cells(ActiveCell.Row, "C")
DOS = Cells(ActiveCell.Row, "S")
TxProvider = Cells(ActiveCell.Row, "P")
LineStatus = Cells(ActiveCell.Row, "T")
Units = Cells(ActiveCell.Row, "AA")
MyID = Name & DOS & Units
If LineStatus = "D" Then
If Not Denied.Exists(MyID) Then
Denied.Add MyID, TxProvider
ElseIf Denied.Exists(MyID) And Not Denied(MyID) = TxProvider Then
If Not Denied2.Exists(MyID) Then
Denied2.Add MyID, TxProvider
Else
MsgBox "Another Denied Dictionary Needed - see " & Name & " on " & DOS
Exit Sub
End If
End If
Else
If Not Paid.Exists(MyID) Then
Paid.Add MyID, TxProvider
ElseIf Not DoubleBill.Exists(MyID) Then
gID = gID + 1
DoubleBill.Add MyID, gID
End If
End If
'***************PROGRESS BAR***************************
CurrentProgress = H / TotalRows
BarWidth = Progress.Border.Width * CurrentProgress
ProgressPercentage = Round(CurrentProgress * 100, 0)
Progress.Bar.Width = BarWidth
Progress.Text.Caption = ProgressPercentage & "% Complete - First Cycle"
DoEvents
H = H + 1
'*********************************************************
ActiveCell(2, 1).Select
Loop
'************PROGRESS BAR******************
Unload Progress
'******************************************
'***************Assigning Groups**************************
Range("A2").Select
'***Progress Bar*********
H = 2
TotalRows = Cells(Rows.Count, 3).End(xlUp).Row
Call InitProgressBar
'*************************
Do Until IsEmpty(ActiveCell)
Name = Cells(ActiveCell.Row, "C")
DOS = Cells(ActiveCell.Row, "S")
TxProvider = Cells(ActiveCell.Row, "P")
LineStatus = Cells(ActiveCell.Row, "T")
Units = Cells(ActiveCell.Row, "AA")
MyID = Name & DOS & Units
If Group.Exists(MyID) Then
Cells(ActiveCell.Row, "AG").Value = Group(MyID)
End If
If Paid.Exists(MyID) And Denied.Exists(MyID) Then
If Paid(MyID) = Denied(MyID) Then
' do nothing
Else
If Rebill.Exists(MyID) Then
Cells(ActiveCell.Row, "AH").Value = Rebill(MyID)
Else
rID = rID + 1
Rebill.Add MyID, rID
Cells(ActiveCell.Row, "AH").Value = Rebill(MyID)
End If
End If
ElseIf Paid.Exists(MyID) And Denied2.Exists(MyID) Then
If Paid(MyID) = Denied2(MyID) Then
' do nothing
Else
If Rebill.Exists(MyID) Then
Cells(ActiveCell.Row, "AH").Value = Rebill(MyID)
Else
rID = rID + 1
Rebill.Add MyID, rID
Cells(ActiveCell.Row, "AH").Value = Rebill(MyID)
End If
End If
End If
'***************PROGRESS BAR***************************
CurrentProgress = H / TotalRows
BarWidth = Progress.Border.Width * CurrentProgress
ProgressPercentage = Round(CurrentProgress * 100, 0)
Progress.Bar.Width = BarWidth
Progress.Text.Caption = ProgressPercentage & "% Complete - Second and Final Cycle"
DoEvents
H = H + 1
'*********************************************************
ActiveCell(2, 1).Select
Loop
'************PROGRESS BAR******************
Unload Progress
'******************************************
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
'************Timer**********************************************
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'***************************************************************
MsgBox "VBA Done - Run time was " & MinutesElapsed
End Sub
Sub InitProgressBar()
With Progress
.Bar.Width = 0
.Text.Caption = "0% Complete - First Cycle"
.Show vbModeless
End With
End Sub
Bookmarks