How to speed up this VBA Code?

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