Need Help Making Macro Faster/More Efficient

The below macro is incredibly slow, on my rather slow computer I calculated it will take about 21 hours to run the macro, which is just ridiculous, I could probably do it manually in the same time or faster.

Is there any obvious way anyone sees to make this code faster?

Also, the commented out part about deleting the rows seems to run into some sort of error I can't figure out....

Thanks!

Sub TheSlowMacro()


'Define Global Variables
BeginRow = 2
EndRow = 19000
Count = 1
UniqueCountMax = 648


'Loop For Each Unique Value
For UniqueValueLoop = Count To UniqueCountMax

    'Select Highest Replay
    With Worksheets("Unique Values")
    refid = .Range("A" & Count)
    End With
    ActiveWorkbook.Worksheets("Unique Values").Cells(Count, 3) = Count
                    
                'Determine Highest Replay
                For RowCnt = BeginRow To EndRow
                            
                            
                            
                            If (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 22).Value = "1") And (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 18).Value = refid) Then
                                HighReplay = 1
                            End If
                            If (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 22).Value = "2") And (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 18).Value = refid) Then
                                HighReplay = 2
                            End If
                            If (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 22).Value = "3") And (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 18).Value = refid) Then
                                HighReplay = 3
                            End If
                            If (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 22).Value = "4") And (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 18).Value = refid) Then
                                HighReplay = 4
                            End If
                            If (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 22).Value = "5") And (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 18).Value = refid) Then
                                HighReplay = 5
                            End If
                            If (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 22).Value = "6") And (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 18).Value = refid) Then
                                HighReplay = 6
                            End If
                            If (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 22).Value = "7") And (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 18).Value = refid) Then
                                HighReplay = 7
                            End If
                            If (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 22).Value = "8") And (ActiveWorkbook.Worksheets("Data").Cells(RowCnt, 18).Value = refid) Then
                                HighReplay = 8
                            End If
                        
                        
                            'Print Highest Number For Each Unique Value
                            ActiveWorkbook.Worksheets("Unique Values").Cells(Count, 2) = HighReplay
                            
                            Next RowCnt
    
    
                'Delete Row For Each Unique Value if not highest replay
                'For DeleteRow = BeginRow To EndRow
                'HighReplayValeu = ActiveWorkbook.Worksheets("Unique Values").Cells(Count, 2).Value
                'If (ActiveWorkbook.Worksheets("Data").Cells(RowCntSecondary, 18).Value = refid) And (ActiveWorkbook.Worksheets("Data").Cells(RowCntSecondary, 22).Value <> HighReplayValue) Then
               ' Cells(RowCntSecondary, "A").EntireRow.Delete
               ' End If
               ' Next DeleteRow
                
    
    
Count = Count + 1
Next UniqueValueLoop




End Sub