Excel - Makro kombinující vybrané řádky
Problém
Mám v aplikaci Excel zdrojová data takto:
CustomerID SalesMonth SalesAmount
12345 Jan 150 12345 březen 100 12345 dub 200 2007878 Jan 800 56789 10. května 78945 20. listopadu 44444 Jan 1000 ....
Kombinace CustomerID a SalesMonth je jedinečná.
A já bych chtěl zkombinovat zdrojová data v jiné kartě Excelu ve formě, jako je tato:
KódZákazníka 1.Mon
12345 leden 150 březen 100 dub 200 200 56789 leden 800 květen 10 78945 20. listopadu 44444 Jan 1000
Celkem může být pro zákazníka až 10 různých měsíců (některé mají pouze 1 nebo 2). Důležité je, že v žádném z výstupních řádků nejsou žádné „mezery“, např. Pokud má zákazník pouze prodej v listopadu, pak buňka „1.Měsíc“ by měla pro tohoto zákazníka přečíst „Nov“.
Řešení
Vyzkoušejte toto makro a viz list 2 (zkopírujte data z listu 1 do listu 3 jako bezpečnostní opatření)
Sub test () Dim zákazník As Range, ddata () As Range, custunq As Range, cunq As Range, rozsah As rozsah Dim dest As Range, j As Long, k As Long With Worksheets ("sheet1") Nastavit zákazníka = Range ( .Range ("A1"), .Range ("A1") Konec (xlDown)) Nastavit custunq = .Range ("A1") Konec (xlDown) .Offset (5, 0) customer.AdvancedFilter xlFilterCopy,, custunq, True Set custunq = Range (custunq.Offset (1, 0), custunq.End (xlDown)) Pro každý custunq V custunq .Range ("A1"). CurrentRegion.AutoFilter pole: = 1, Kritéria1: = custunq.Value Nastavit 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 až j) Se listy ("sheet2") Nastavte dest = .Cells (Rows.Count, "A"). Konec (xlUp) .Offset (1, 0) dest = filt (1, 1) Konec s pro k = 1 Do j Nastavit ddata (k) = .Range (filt (k, 2), filt (k, 3)) ddata (k) .Kopírujte s listy ("sheet2") .Cells (dest.Row, Columns.Count) .End (xlToLeft) .Offset (0, 1) .PasteSpecial End With Next k .Range ("A1"). CurrentRegion.AutoFilter Další rozsah custunq (.Range ("a1"). Konec (xlDown) .Offset (1, 0), .Cells (Rows.Count, "A"). Konec (xlUp)) EntireRow.Delete End With End Sub Sub undo () Pracovní listy ("sheet2") Cells.Clear End Sub Děkujeme Venkat1926 za tento tip.