Excel - Ein Makro zum Kombinieren ausgewählter Zeilen
Problem
Ich habe Quelldaten in Excel, die so aussehen:
CustomerID SalesMonth SalesAmount
12345 Jan 150 12345 Mar 100 12345 Apr 200 56789 Jan 800 56789 May 10 78945 Nov 20 44444 Jan 1000 ....
Die Kombination von CustomerID und SalesMonth ist einzigartig.
Und ich möchte die Quelldaten in einer anderen Excel-Registerkarte in einer Form wie dieser kombinieren:
KundenID 1.Monat 1.Monat 2.Monat 2.Monat 3.Monat 3.Monat
12345 Jan 150 Mar 100 Apr 200 56789 Jan 800 May 10 78945 Nov 20 44444 Jan 1000
Insgesamt kann es für einen Kunden bis zu 10 verschiedene Monate geben (einige haben nur 1 oder 2). Wichtig ist, dass in keiner der Ausgabezeilen Lücken vorhanden sind, z. B. wenn ein Kunde nur im November Verkäufe getätigt hat, sollte in der Zelle "1stMonth" für diesen Kunden "Nov" angezeigt werden.
Lösung
Probieren Sie dieses Makro aus und lesen Sie Blatt 2 (kopieren Sie die Daten aus Sicherheitsgründen in Blatt 1 bis Blatt 3).
Untertest () 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 Mit Arbeitsblättern ("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)) Für jedes custunq In custunq .Range ("A1"). CurrentRegion.AutoFilter field: = 1, Criteria1: = custunq.Value Setze filt = .Range ("A1"). CurrentRegion.Offset (1, 0) .Resize (Rows.Count - 1, Columns.Count). _ SpecialCells (xlCellTypeVisible) j = WorksheetFunction.CountA (filt.Columns (1)) 'MsgBox j Daten (1 bis j) mit Arbeitsblättern neu dimensionieren ("sheet2") Ziel = .Cells (Rows.Count, "A") festlegen. End (xlUp) .Offset (1, 0) dest = filt (1, 1) End With For k = 1 To j Setze 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 Nächster Kundenbereich (.Range ("a1"). End (xlDown) .Offset (1, 0) .Cells (Rows.Count, "A"). End (xlUp)). EntireRow.Delete End With End Sub Sub undo () Arbeitsblätter ("sheet2"). Cells.Clear End Sub Danke an Venkat1926 für diesen Tipp.