0
Thanks

A few words of thanks would be greatly appreciated.

# Excel - A macro to combine selected rows

## Issue

I have source data in Excel looking like this:

CustomerID SalesMonth SalesAmount

```12345 Jan 150
12345 Mar 100
12345 Apr 200
56789 Jan 800
56789 May 10
78945 Nov 20
44444 Jan 1000
.... ```

The combination of CustomerID and SalesMonth is unique.

And I would like to combine the source data in a different Excel tab in a form like this:

CustomerID 1stMonth 1stAmount 2ndMonth 2ndAmount 3rdMonth 3rdAmount

```12345 Jan 150 Mar 100 Apr 200
56789 Jan 800 May 10
78945 Nov 20
44444 Jan 1000
```

In total there can be up to 10 different months for a customer (some have only 1 or 2). Important is that there are no 'gaps' in any of the output rows, eg if a customer has sales only in Nov, then the '1stMonth' cell should read 'Nov' for that customer.

## Solution

Try this macro and see sheet 2(copy data in sheet 1 to sheet 3 as safety precaution)

```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)
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```

Thanks to Venkat1926 for this tip.

0
Thanks

A few words of thanks would be greatly appreciated.