Try this:-

Results Start Sheet(2) "A1".

Code:

Sub MG22Nov26
Dim Rng As Range
Dim Dn As Range
Dim AcRng As Range
Dim Col As Range
Dim Txt As String
Dim Num As Long
Dim c As Long
Num = ActiveSheet.Range("A1").CurrentRegion.Count
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
ReDim Ray(1 To Num, 1 To 3)
For Each Dn In Rng
Set AcRng = Range(Range("B" & Dn.Row), Cells(Dn.Row, Columns.Count).End(xlToLeft))
For Each Col In AcRng
If Col.Column = 2 Then
Txt = "First"
ElseIf Col.Column = AcRng.Count + 1 Then
Txt = "Last"
Else
Txt = Col.Column - 1
End If
c = c + 1
Ray(c, 1) = Dn
Ray(c, 2) = Col
Ray(c, 3) = Txt
Next Col
Next Dn
With Sheets("Sheet2")
.Range("A1").Resize(, 3) = Array("ID", "P", "Rank")
.Range("A2").Resize(c, 3) = Ray
End With
End Sub

Regards Mick

## Like this thread? Share it with others