Excel - макрос за комбиниране на избрани редове

Проблем

Имам изходни данни в Excel, които изглеждат така:

CustomerID SalesMonth SalesAmount

 12345 Яну 150 12345 Мар 100 12345 Април 200 56789 Яну 800 56789 Май 10 78945 Ное 20 44444 Яну 1000 

Комбинацията от CustomerID и SalesMonth е уникална.

Искам да комбинирам изходните данни в друг раздел на Excel в такава форма:

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

 12345 Яну 150 Мар 100 Април 200 56789 Яну 800 Май 10 78945 Ное 20 44444 Яну 1000 

Общо може да има до 10 различни месеца за един клиент (някои имат само 1 или 2). Важно е, че няма "пропуски" в нито един от изходните редове, например ако клиентът има продажби само през ноември, тогава клетката "1stMonth" трябва да чете "Nov" за този клиент.

Решение

Опитайте този макрос и вижте лист 2 (копирайте данните в лист 1 в лист 3 като предпазна мярка за безопасност)

 Под-тест () Dim клиент As Range, ddata () As Range, custunq As Range, cunq As Range, filt Като обхват Дим дест като обхват, j Както дълъг, k толкова дълъг с работни листове ("sheet1") Задайте клиент = Обхват ( Край (xlDown)) Задайте custunq = .Range ("A1"). Край (xlDown) .Offset (5, 0) customer.AdvancedFilter xlFilterCopy,, custunq, True Set custunq = Обхват (custunq.Offset (1, 0), custunq.End (xlDown)) За всеки custunq В custunq .Range ("A1"). CurrentRegion.AutoFilter поле: = 1, Критерий1: = custunq.Value Поставете filt = .Range ("A1"). CurrentRegion.Offset (1, 0) .Размер (Rows.Count - 1, Columns.Count). _ SpecialCells (xlCellTypeVisible) j = WorksheetFunction.CountA (filt.Columns (1)) 'MsgBox j ReDim ddata (1 до j) С работни листове ("лист2") Задайте цел =. Край (xlUp) .Offset (1, 0) dest = filt (1, 1) Край С За k = 1 К j Задаване на ddata (k) = .Range (filt (k, 2), filt (k, 3)) Копиране с работни листове ("лист2") .Калони (dest.Row, Columns.Count). End (xlToLeft) .Offset (0, 1) .PasteSpecial End with Next k .Range ("A1"). CurrentRegion.AutoFilter Следващ обхват на custunq (.Range ("a1"). Край (xlDown) .Offset (1, 0), .Cells (Rows.Count, "A"). End (xlUp)). EntireRow.Delete End With Край на Sub Sub undo () Работни листове ("sheet2"). Cells.Clear End Sub 

Благодарение на Venkat1926 за този съвет.