16. november 2015 - 08:46Der er
7 kommentarer og 1 løsning
VBA converter matrix til tabel/liste format
Hej eksperter
jeg har brug for hjælp til at skrive og forstå en VBA kode som jeg jævnligt skal bruge i modificeret form. Jeg modtager ofte data I excel I matrix format a la nedenstående:
Account Name Type Jan Feb Mar ... Dec 601040 Tests Cost 100 150 105 ... 254 601041 Office Cost 200 250 255 ... 245 700001 Intern Hour 105 115 175 ... 225
I dette tilfælde har jeg altså 3 kolonner med oplysninger + 12 kolonner med værdier(en kolonne per måned). Det vil jeg gerne have omdannet til en table/liste med kun en værdikolonne, som kan bruges som input til pivottabeller:
Account Name Type Month Value 601040 Tests Cost Jan 100 601040 Tests Cost Feb 150 601040 Tests Cost Mar 105 601040 Tests Cost ... 601040 Tests Cost Dec 254 601041 Office Cost Jan 200 601041 Office Cost Feb 250
... ..
Jeg har fundet masser af VBA koder på nettet der kan konvertere en matrix til en 3 kolonners table, men jeg kan ikke finde ud af at omskrive dem, så de kan håndterer situationer hvor der er flere kolonner med oplysninger + 12 værdikolonner.
Det er meget forskelligt hvormange kolonner jeg har med oplysninger, fx det jeg arbejder med lige nu har 15 kolonner, så jeg skal altså bruge en kode der er dynamisk nok til at kunne håndtere dette + som jeg skal kunne forstå så meget, at jeg kan tilpasse den til behovet.
Dim antalRækker As Integer, antalKolonner As Integer, antalInfoKolonner As Integer Dim ræk As Integer, ræk2 As Integer, kol As Integer Public Sub klargørTilPivot() antalRækker = ActiveCell.SpecialCells(xlLastCell).Row antalKolonner = ActiveCell.SpecialCells(xlLastCell).Column
antalInfoKolonner = antalKolonner - 12
Rem sæt overskrifter - 5 rækker efter sidste række af oprindelige rækker ræk2 = antalRækker + 5 For kol = 1 To antalInfoKolonner Range("A" & ræk2).Offset(0, kol - 1) = Range("A1").Offset(0, kol - 1) Next kol Range("A" & ræk2).Offset(0, kol - 1) = "Month" Range("A" & ræk2).Offset(0, kol) = "Value" ræk2 = ræk2 + 1
Rem Opbygger For ræk = 2 To antalRækker Range(Cells(ræk, 1), Cells(ræk, antalInfoKolonner)).Copy Range("A" & ræk2).Select ActiveSheet.Paste
For kol = antalInfoKolonner + 1 To antalKolonner Range("A" & ræk2).Select ActiveSheet.Paste Cells(ræk2, antalInfoKolonner + 1) = Cells(1, kol) Cells(ræk2, antalInfoKolonner + 2) = Cells(ræk, kol) ræk2 = ræk2 + 1 Next kol Application.CutCopyMode = False Next ræk End Sub
øv! Koden virkede fint på min lille test på 10 rækker. Men performance er ikke god på min totale matrix på 10.000 rækker..... Supertekst kan du gøre noget? Skal jeg oprette et nyt spørgsmål, for jeg har jo ikke fået beskrevet omfanget godt nok I dette spørgsmål!
Rem Version 2 Dim antalRækker As Integer, antalKolonner As Integer, antalInfoKolonner As Integer Dim ræk As Long, ræk2 As Long, kol As Integer, kol2 As Integer Public Sub klargørTilPivot() Application.ScreenUpdating = False
Rem sæt overskrifter - 5 rækker efter sidste række af oprindelige rækker ræk2 = antalRækker + 5 For kol = 1 To antalInfoKolonner Range("A" & ræk2).Offset(0, kol - 1) = Range("A1").Offset(0, kol - 1) Next kol Range("A" & ræk2).Offset(0, kol - 1) = "Month" Range("A" & ræk2).Offset(0, kol) = "Value" ræk2 = ræk2 + 1 kol2 = antalInfoKolonner + 1
Rem Opbygger For ræk = 2 To antalRækker For kol = 1 To antalKolonner If kol <= antalInfoKolonner Then Range("A" & ræk2).Offset(0, kol - 1) = Range("A" & ræk).Offset(0, kol - 1) Else Cells(ræk2, antalInfoKolonner + 1) = Cells(1, kol2) Cells(ræk2, antalInfoKolonner + 2) = Cells(ræk, kol2) ræk2 = ræk2 + 1 kol2 = kol2 + 1 kol = 0 End If If kol2 > antalKolonner Then Exit For End If Next kol kol2 = antalInfoKolonner + 1 Next ræk End Sub
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
