Hi Philip,
try this:
Sub PhilipJ(): Dim w1 As Worksheet, w2 As Worksheet, B As Object, O As Object
Dim i As Long, r As Long, Key As String, k
Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
r = w1.Range("A" & Rows.Count).End(xlUp).Row
Set B = CreateObject("Scripting.Dictionary")
Set O = CreateObject("Scripting.Dictionary")
For i = 2 To r: Key = Replace(Trim(w1.Cells(i, 5)), "*", "")
If Key = "" Then GoTo GetNext
If Right(Key, 4) = "FORD" Or Right(Key, 3) = "JLR" Or _
Right(Key, 3) = "POC" Or Right(Key, 2) = "FM" Then
If B.Exists(Key) Then
B.Item(Key) = B.Item(Key) + 1
If w1.Cells(i, 1) = 1 Then O.Item(Key) = O.Item(Key) + 1
Else
B.Item(Key) = 1
If w1.Cells(i, 1) = 1 Then
O.Item(Key) = 1
Else: O.Item(Key) = 0: End If
End If
End If
GetNext: Next i: k = B.Keys()
BubbleK:
For r = LBound(k) To UBound(k) - 1
If k(r) > k(r + 1) Then
Key = k(r): k(r) = k(r + 1): k(r + 1) = Key
GoTo BubbleK: End If: Next r: r = 2
For i = LBound(k) To UBound(k)
w2.Cells(r, 1) = k(i): w2.Cells(r, 2) = B.Item(k(i)): w2.Cells(r, 3) = O.Item(k(i))
r = r + 1: Next i
End Sub
Bookmarks