this code works on attached sample (position only one char)
Code:
Sub a()
LRA = Cells(Rows.Count, "A").End(xlUp).Row
LRE = Cells(Rows.Count, "E").End(xlUp).Row
drow = 3
Range("A3:B" & LRA).Sort key1:=Range("a3"), order1:=xlAscending, key2:=Range("B3"), order2:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
s1 = Cells(3, 1) & "_" & Cells(3, 2)
For r = 4 To LRA
If Cells(r, 1) = Cells(r - 1, 1) Then
s1 = s1 & Cells(r, 2)
Else
s1 = s1 & Cells(r, 1) & "_" & Cells(r, 2)
End If
Next
Range("E3:F" & LRE).Sort key1:=Range("E3"), order1:=xlAscending, key2:=Range("F3"), order2:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
s2 = Cells(3, "E") & "_" & Cells(3, "F")
For r = 4 To LRA
If Cells(r, "E") = Cells(r - 1, "E") Then
s2 = s2 & Cells(r, "F")
Else
' Stop
cand = Left(s2, InStr(s2, "_") - 1)
cond = Right(s2, Len(s2) - InStr(s2, "_"))
Cells(drow, "I") = cand
p = InStr(s1, cond)
If p > 0 Then
Cells(drow, "J") = Mid(s1, p - 2, 1)
Else
Cells(drow, "J") = "N/A"
End If
drow = drow + 1
s2 = Cells(r, "E") & "_" & Cells(r, "F")
End If
Next
End Sub
Bookmarks