Sub RunMe() Dim sSheet, dSheet As Worksheet Dim x, y As Integer 'Source and Destination sheets. Adjust to match yours. Set sSheet = Sheets("Sheet1") Set dSheet = Sheets("Sheet2") x = 5 sSheet.Range("A5:D" & sSheet.Range("A5").End(xlDown).Row).Copy dSheet.Range("A5") dSheet.Range("A5:D" & dSheet.Range("A5").End(xlDown).Row).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo For Each cell In dSheet.Range("A5:A" & Range("A" & Rows.Count).End(xlUp).Row) Do If cell.Value = sSheet.Range("A" & x).Value Then y = 5 Do If sSheet.Range("E" & x).Value = dSheet.Cells(2, y).Value Then Exit Do y = y + 6 Loop Until dSheet.Cells(2, y).Value = vbNullString sSheet.Range(sSheet.Cells(x, "F"), sSheet.Cells(x, "K")).Copy dSheet.Cells(cell.Row, y) End If x = x + 1 Loop Until cell.Value <> sSheet.Range("A" & x).Value Next cell End Sub
DON'T MISS