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

Of course it is going to take forever. You have a loop within a loop doing 19000 loops, 648 times. So that is 12 million times you are running your code. Did you expect it to be instantaneous? Not only that but you didn't declare any variables so everything is running as a variant.

A possible solution (not sure because we get no other information than your code. This is untested)

Sub TheSlowMacro()
Dim ws As Worksheet:    Set ws = Sheets("Data")
Dim UniqueValueLoop As Long, RowCnt As Long, HighReplay As Long
Dim refid As String

Application.ScreenUpdating = False

'Loop For Each Unique Value
For UniqueValueLoop = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row

    'Select Highest Replay
    refid = ws.Range("A" & UniqueValueLoop).Value
    ws.Cells(UniqueValueLoop, 3) = UniqueValueLoop
                    
                'Determine Highest Replay
                For RowCnt = 2 To ws.Range("V" & Rows.Count).End(xlUp).Row
                            
                            If ws.Cells(RowCnt, 18).Value = refid Then
                                Select Case ws.Cells(RowCnt, 22).Value
                                    Case Is = "1"
                                        HighReplay = 1
                                    Case Is = "2"
                                        HighReplay = 2
                                    Case Is = "3"
                                        HighReplay = 3
                                    Case Is = "4"
                                        HighReplay = 4
                                    Case Is = "5"
                                        HighReplay = 5
                                    Case Is = "6"
                                        HighReplay = 6
                                    Case Is = "7"
                                        HighReplay = 7
                                    Case Is = "8"
                                        HighReplay = 8
                                End Select
                          
                            'Print Highest Number For Each Unique Value
                            ActiveWorkbook.Worksheets("Unique Values").Cells(UniqueValueLoop, 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
                

Next UniqueValueLoop

Application.ScreenUpdating = True

End Sub

I know it is going to take forever, and on top of that I still need to run the loop thats commented out... this is like the third time I've ever used VB or made a macro, and I havn't done any programming in years (and that was just basic classes in HS) its why i asked for help here....

Did the above amended macro work for your situation? If you want further assistance you will probably need to upload a copy of your workbook, with the sensitive material removed, so that we can get a better feel for what is going on.

Originally Posted by stnkynts

Did the above amended macro work for your situation? If you want further assistance you will probably need to upload a copy of your workbook, with the sensitive material removed, so that we can get a better feel for what is going on.

It would be faster to make a dummy spreadsheet than remove the sensitive data which is virtually all of it.

I have not had a chance to try it, but the bottom part that is commented out I solved myself, I was just missing an "End If" statement. But it seems to delete only a few rows that it should not all of them... ill post more info later when i have a chance to look at it some more thanks.

Thanks thats all I needed to make this work properly, still slow, but I found a faster computer to run it on and it only takes 20 minutes to run on that computer.

Originally Posted by judgeh59

On the delete row area....you may want to switch the startrow and endrow...when you are deleting rows like this the FOR loop counter gets confused and actually skips over rows because you have deleted a row and the FOR loop counter get incremented...so if you work backwards it should work...the other way is to keep the BeginRow and EndRow the same but inside the IF statement and after the actual Delete decrement DeleteRow....HTH

For DeleteRow = EndRow to BeginRow step -1