Sub Compare()
Dim sArr As Variant, dArr As Variant, Res(), Rng As Range, Rng2 As Range
Dim i As Long, k As Long, ik, j As Byte, iKey
Call ClearCompare
With Sheets("W2")
i = .Range("G" & Rows.Count).End(xlUp).Row
If i > 4 Then sArr = .Range("G5:L" & i).Value: k = UBound(sArr)
i = .Range("M" & Rows.Count).End(xlUp).Row
If i > 4 Then dArr = .Range("M5:R" & i).Value: k = k + UBound(dArr)
End With
If k = 0 Then Exit Sub
ReDim Res(1 To k, 1 To 6)
k = 0
With CreateObject("scripting.dictionary")
If IsArray(sArr) Then
For i = 1 To UBound(sArr)
iKey = sArr(i, 1) & "#" & sArr(i, 2) & "#" & sArr(i, 3)
If Len(iKey) > 2 Then
k = k + 1
.Item(iKey) = k
For j = 1 To 6
If j <> 5 Then Res(k, j) = sArr(i, j)
Next j
End If
Next i
End If
If IsArray(dArr) Then
For i = 1 To UBound(dArr)
iKey = dArr(i, 1) & "#" & dArr(i, 2) & "#" & dArr(i, 3)
If .exists(iKey) Then
ik = .Item(iKey)
If dArr(i, 6) <> Res(ik, 6) Then Res(ik, 5) = dArr(i, 6)
.Remove (iKey)
Else
k = k + 1
For j = 1 To 4
Res(k, j) = dArr(i, j)
Next j
Res(k, 5) = dArr(i, 6)
End If
Next i
If .Count > 0 Then
For Each ik In .items
Res(ik, 5) = "a"
Next
End If
End If
End With
With Sheets("W2")
.Range("A5:F5").Resize(k) = Res
ik = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A4:F" & ik).Sort .[A4], 1, .[B4], , 1, .[C4], , 1, Header:=xlYes
If IsArray(dArr) Then
For i = 5 To ik
iKey = .Range("E" & i)
If Len(iKey) Then
If iKey = "a" Then
.Range("E" & i).ClearContents
Set Rng2 = .Range("A" & i).Resize(, 6)
Else
Set Rng2 = .Range("F" & i)
End If
If Rng Is Nothing Then Set Rng = Rng2 Else Set Rng = Union(Rng, Rng2)
If Rng.Count > 30 Then
Rng.Range("F7").Font.Color = -16776961
Rng.Range("F7").Font.FontStyle = "Italic"
Set Rng = Nothing
End If
End If
Next i
If Not Rng Is Nothing Then
Rng.Font.Color = -16776961
Rng.Font.FontStyle = "Italic"
End If
Set Rng = Nothing: Set Rng2 = Nothing
With .Range("E5:E" & ik)
.Font.Color = -16776961
.Font.FontStyle = "Italic"
.Font.Strikethrough = True
End With
Else
With .Range("A5:F" & ik)
.Font.Color = -16776961
.Font.FontStyle = "Italic"
End With
End If
End With
End Sub
Sub ClearCompare()
Dim i As Long
With Sheets("W2")
i = .Range("A" & Rows.Count).End(xlUp).Row
If i > 4 Then
With .Range("A5:F" & i)
.ClearContents
.Font.Italic = False
.Font.ColorIndex = xlAutomatic
End With
End If
End With
End Sub
