Sub test()
Dim a(1), b, i&, ii&, n&, x&, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("sheet2")
With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 14)
a(0) = Application.Index(.Value, Evaluate("row(2:" & .Rows.Count & ")"), [{1,2,5,8,14}])
End With
End With
For i = 1 To UBound(a(0), 1)
dic(a(0)(i, 1)) = Array(i, Join(Application.Index(a(0), i, 0), Chr(2)))
Next
With Sheets("sheet1")
With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 14)
a(1) = Application.Index(.Value, Evaluate("row(2:" & .Rows.Count & ")"), [{1,2,5,8,14}])
End With
End With
ReDim b(1 To UBound(a(1), 1), 1 To UBound(a(1), 2) * 2 + 2)
For i = 1 To UBound(a(1), 1)
If dic.exists(a(1)(i, 1)) Then
If dic(a(1)(i, 1))(1) <> Join(Application.Index(a(1), i, 0), Chr(2)) Then
n = n + 1
For ii = 1 To UBound(a(1), 2)
b(n, ii) = a(1)(i, ii)
b(n, ii + UBound(b, 2) / 2) = a(0)(dic(a(1)(i, 1))(0), ii)
If b(n, ii) <> b(n, ii + UBound(b, 2) / 2) Then
b(n, UBound(b, 2)) = b(n, UBound(b, 2)) + 1
End If
Next
End If
End If
Next
With Sheets("results")
With .Rows("4:" & .Cells.SpecialCells(11).Row)
.ClearContents: .Interior.ColorIndex = xlNone
End With
If n Then
.[b4].Resize(n, UBound(b, 2)) = b
With .Rows(3).SpecialCells(2).Areas(2)
With .CurrentRegion.Resize(, .Columns.Count - 1)
.FormatConditions.Delete
.FormatConditions.Add 2, Formula1:="=" & .Cells(1).Address(0, 0) & "<>b3"
.FormatConditions(1).Interior.Color = rgbLightBlue
End With
End With
End If
End With
End Sub
www.dropbox.com
