Compare. Copy/paste if first score is highest

[Hank2]

I have a list of names in Column 1 down to 1056 rows but that size will vary. There are no spaces between the names. The number in column 2 corresponds to the score for those names. In most cases the names are repeated 10 times with different scores. Sometimes there will not be 10 names and 10 scores. It will vary, like 3 names and 3 scores etc.

What I want is a macro (not a formula) that will look at the scores related to a specific name. If the first score for that name is higher than the rest of its scores (or tied to its highest score) I would like that noted by copying that name and score and pasting it on sheet 2 starting R1C1.

For example, the first name is GIANT PULPIT. His first score is 90 and it is higher than any other score he has. It would be copied and pasted to sheet 2 R1C1. The next name is TWO TIMING. That name's first score is 56. That is not his highest score and would be ignored. Move to the next name. CRIME WAVE's first score is a 75. Even though it is tied for his highest score
from 4 back, that would get copied and pasted to sheet 2 R2C1. Thanks

GIANT PULPIT 90
GIANT PULPIT 68
GIANT PULPIT 75
GIANT PULPIT 70
GIANT PULPIT 77
GIANT PULPIT 64
GIANT PULPIT 68
GIANT PULPIT 78
GIANT PULPIT 70
GIANT PULPIT 0
TWO TIMING 56
TWO TIMING 66
TWO TIMING 69
TWO TIMING 88
TWO TIMING 71
TWO TIMING 73
TWO TIMING 63
TWO TIMING 69
TWO TIMING 62
CRIME WAVE 75
CRIME WAVE 55
CRIME WAVE 64
CRIME WAVE 75
CRIME WAVE 69
CRIME WAVE 55
CRIME WAVE 66
CRIME WAVE 69
CRIME WAVE 62
CRIME WAVE 67

So sheet 2 would look like this at this point


GIANT PULPIT 90
CRIME WAVE 75

 

[Trebor76]

Hi Hank2,

Try this:

Option Explicit
Sub Macro1()

    Dim lngStartRow As Long
    Dim lngLastRow As Long
    Dim lngMyRow As Long
    Dim lngPasteRow As Long
    
    Application.ScreenUpdating = False
    
    lngStartRow = 1 'Assumes source data starts at Row 2 on Sheet1. Change to suit if necessary.
    lngPasteRow = 1 'Initial output row on Sheet2. Change to suit if necessary.
    lngLastRow = Sheets("Sheet1").Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngStartRow To lngLastRow
        If lngMyRow = lngStartRow Then
            If Evaluate("MAX(IF('Sheet1'!$A$" & lngStartRow & ":$A$" & lngLastRow & "='Sheet1'!A" & lngMyRow & ",'Sheet1'!$B$" & lngStartRow & ":$B$" & lngLastRow & "))") = Sheets("Sheet1").Range("B" & lngMyRow) Then
                Sheets("Sheet1").Range("A" & lngMyRow & ":B" & lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & lngPasteRow)
                lngPasteRow = lngPasteRow + 1
            End If
        ElseIf Sheets("Sheet1").Range("A" & lngMyRow) <> Sheets("Sheet1").Range("A" & lngMyRow - 1) Then
            If Evaluate("MAX(IF('Sheet1'!$A$" & lngStartRow & ":$A$" & lngLastRow & "='Sheet1'!A" & lngMyRow & ",'Sheet1'!$B$" & lngStartRow & ":$B$" & lngLastRow & "))") = Sheets("Sheet1").Range("B" & lngMyRow) Then
                Sheets("Sheet1").Range("A" & lngMyRow & ":B" & lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & lngPasteRow)
                lngPasteRow = lngPasteRow + 1
            End If
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Hank2]

Thanks Robert

But I get a Type mismatch (run time Error 13) when the macro tries to execute

If Evaluate("MAX(IF('Sheet1'!$A$" & lngStartRow & ":$A$" & lngLastRow & "='Sheet1'!A" & lngMyRow & ",'Sheet1'!$B$" & lngStartRow & ":$B$" & lngLastRow & "))") = Sheets("Sheet1").Range("B" & lngMyRow) Then

 

[Trebor76]

Not sure as it worked for me
Make sure there’s no errors like #N/A in either column A or B and try again.

 

[Hank2]

My bad. I was using the numeric style and when I switched to alpha it worked. Thank You for your help. Much appreciated.