Excel - En makro for å kombinere utvalgte rader

Utgave

Jeg har kilde data i Excel ser slik ut:

CustomerID SalesMonth SalesAmount

 12345 jan 150 12345 mar 100 12345 apr 200 56789 jan 800 56789 mai 10 78945 nov 20 44444 jan 1000 .... 

Kombinasjonen av CustomerID og SalesMonth er unik.

Og jeg vil gjerne kombinere kildedataene i en annen Excel-kategori i et slikt format:

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

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

Totalt kan det være opptil 10 forskjellige måneder for en kunde (noen har bare 1 eller 2). Viktig er at det ikke er noen "hull" i noen av produksjonsrader, for eksempel hvis en kunde kun har salg i november, så burde 1Month-cellen lese "november" for den aktuelle kunden.

Løsning

Prøv denne makroen og se ark 2 (kopier data i ark 1 til ark 3 som sikkerhetstiltak)

 Sub-test () Dim-kunde Som rekkevidde, ddata () Som rekkevidde, custunq As Range, cunq As Range, filt As Range Dim dest As Range, j Så lenge, så lenge med regneark .Range ("A1") .Range ("A1"). End (xlDown)) Angi custunq = .Range ("A1"). End (xlDown) .Offset (5, 0) customer.AdvancedFilter xlFilterCopy, custunq, True Set custunq = Range (custunq.Offset (1, 0), custunq.End (xlDown)) For hver custunq I custunq .Range ("A1"). CurrentRegion.AutoFilter feltet: = 1, Criteria1: = custunq.Value Sett 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 til j) Med regneark ("ark2") Angi dest = .Cells (Rows.Count, "A"). End (xlUp) .Offset (1, 0) dest = filt (1, 1) Slutt med For k = 1 Til j Sett ddata (k) = .Range (filt (k, 2), filt (k, 3)) ddata (k) .Kopi med regneark ("ark2") .Cells (dest.Row, Columns.Count) .End (xlToLeft) .Offset (0, 1) .PasteSpecial End med neste k .Range ("A1"). CurrentRegion.AutoFilter Next custunq Range (.Range ("a1"). End (xlDown) .Offset (1, 0) .Cells (Rows.Count, "A"). End (xlUp)) .HeleRow.Delete End With Slutt Sub Sub undo () Worksheets ("sheet2"). Cells.Clear End Sub 

Takk til Venkat1926 for dette tipset.