Sub ertert()
Dim x, i&, k, s$, t
x = Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(x)
s = x(i, 1) & "~" & x(i, 2) & "~" & x(i, 3) & "~" & x(i, 4)
If .Exists(s) Then
If .Item(s) <> x(i, 5) Then
t = IIf(x(i, 5) > 0, .Item(s), x(i, 5))
With Sheets("Sheet4").Cells(Rows.Count, 1).End(xlUp)(2)
.Resize(2, 5).Value = Cells(i, 1).Resize(, 5).Value
.Item(, 5).Value = t: .Item(2, 5).Value = 1
End With
.Remove s
Else
Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 5).Value _
= Cells(i, 1).Resize(, 5).Value
End If
Else
.Item(s) = x(i, 5)
End If
Next i
For Each k In .keys
t = .Item(k): s = IIf(t > 0, "Sheet3", "Sheet2")
With Sheets(s).Cells(Rows.Count, 1).End(xlUp)(2)
.Resize(, 4).Value = Split(k, "~"): .Item(, 5).Value = t
End With
Next k
End With
End Sub