Sub AnyThing() Dim lastrow_1 As Long, counter As Long Dim lastrow_2 As Long, key As Variant Dim sh1 As Worksheet, sh2 As Worksheet Dim rng1, rng2 As Range, p As Variant Dim dict As Object Set sh1 = Sheets("SHEET1") Set sh2 = Sheets("SHEET2") sh2.Range("K4").Resize(1000, 5).ClearContents 'I3 > K4 & 3 > 5 lastrow_1 = sh1.Cells(sh1.Rows.Count, "B").End(3).Row lastrow_2 = sh2.Cells(sh2.Rows.Count, "C").End(3).Row 'sh1 > sh2 Set rng1 = sh1.Range("B4:E" & lastrow_1) '3 > 4 Set rng2 = sh2.Range("C5:E" & lastrow_2) '2 > 5 Set dict = CreateObject("Scripting.Dictionary") For Each p In rng1.Columns(1).Cells '2 > 1 If Not dict.Exists(p.Value & "," & p.Offset(, 1) & "," & p.Offset(, 2)) Then 'Add & "," & p.Offset(, 2) dict.Add p.Value & "," & p.Offset(, 1) & "," & p.Offset(, 2), p.Offset(, 3) 'Adjust according to previous line Else dict(p.Value & "," & p.Offset(, 1) & "," & p.Offset(, 2)) = _ dict(p.Value & "," & p.Offset(, 1) & "," & p.Offset(, 2)) + p.Offset(, 3) 'Adjust according to previous lines End If Next p '=============================== For Each p In rng2.Columns(1).Cells '2 > 1 If Not dict.Exists(p.Value & "," & p.Offset(, 1) & "," & p.Offset(, 2)) Then 'Add & "," & p.Offset(, 2) dict.Add p.Value & "," & p.Offset(, 1) & "," & p.Offset(, 2), p.Offset(, 3) 'Adjust according to previous line Else dict(p.Value & "," & p.Offset(, 1) & "," & p.Offset(, 2)) = _ dict(p.Value & "," & p.Offset(, 1) & "," & p.Offset(, 2)) + p.Offset(, 3) 'Adjust according to previous lines End If Next p '============================== counter = 3 '2 > 3 With sh2 For Each key In dict.Keys counter = counter + 1 .Cells(counter, "K").Resize(1, 3) = Split(key, ",") '2 > 3 .Cells(counter, "N") = dict(key) 'O > N Next key End With dict.RemoveAll: Set dict = Nothing Set sh1 = Nothing: Set sh2 = Nothing Set rng1 = Nothing: Set rng2 = Nothing End Sub
DON'T MISS
you can see my images