Sub test() Dim customer As Range, ddata() As Range, custunq As Range, cunq As Range, filt As Range Dim dest As Range, j As Long, k As Long With Worksheets("sheet1") Set customer = Range(.Range("A1"), .Range("A1").End(xlDown)) Set custunq = .Range("A1").End(xlDown).Offset(5, 0) customer.AdvancedFilter xlFilterCopy, , custunq, True Set custunq = Range(custunq.Offset(1, 0), custunq.End(xlDown)) For Each custunq In custunq .Range("A1").CurrentRegion.AutoFilter field:=1, Criteria1:=custunq.Value Set filt = .Range("A1").CurrentRegion.Offset(1, 0).Resize(Rows.Count - 1, Columns.Count). _ SpecialCells(xlCellTypeVisible) j = WorksheetFunction.CountA(filt.Columns(1)) 'MsgBox j ReDim ddata(1 To j) With Worksheets("sheet2") Set dest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) dest = filt(1, 1) End With For k = 1 To j Set ddata(k) = .Range(filt(k, 2), filt(k, 3)) ddata(k).Copy With Worksheets("sheet2") .Cells(dest.Row, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial End With Next k .Range("A1").CurrentRegion.AutoFilter Next custunq Range(.Range("a1").End(xlDown).Offset(1, 0), .Cells(Rows.Count, "A").End(xlUp)).EntireRow.Delete End With End Sub
Sub undo() Worksheets("sheet2").Cells.Clear End Sub
DON'T MISS
Thanks so much - this does exactly what I needed!