04. april 2009 - 12:53Der er
7 kommentarer og 1 løsning
Hvordan samler man flere excel ark i ét (dynamisk)?
Hej eksperter!
Jeg har et excel regneark med 7 ark inde i (fanerne i bunden), 6 af de 7 ark indeholder prisliste for én varegruppe så når jeg skal skrive prislister ud skal jeg skrive arkene ud enkeltvis, og nogle varegrupper fylder kun et halvt A4 ark.
Jeg kunne godt tænke mig at samle 3 kolonner og alle linier fra de 6 ark på det første ark med en overskrift (ex. arkets navn) og et linieskift imellem hver af dem således at jeg kun skal skrive det ud fra ét ark.
Jeg kan godt finde ud af at lave det manuelt (henvise til data fra de enkelte ark i det første) - men hvordan får man gjort det på en måde så den selv finder ud af hvor mange linier der er i arket og gør plads til netop det antal i udskrifts-arket?
Håber I forstår hvad jeg mener - ellers må I endelige spørge!!
Sub samle() Set dest = Sheets("Ark1") dest.Range("A1:C10000") = "" ' sletter gl værdier For Each sh In ThisWorkbook.Sheets If sh.Name <> dest.Name Then dest.Cells(dest.Cells(65500, "A").End(xlUp).Offset(2, 0).Row, "A") = sh.Name rk = sh.Cells(65500, "A").End(xlUp).Row + 1 rk2 = dest.Cells(65500, "A").End(xlUp).Row + 1 x = sh.Range("A1:A" & rk) dest.Range("A" & rk2 & ":C" & rk2 + rk - 1) = x End If Next End Sub
ret Ark1 til aktuel samleark denne kopierer værdier i ark 2-7 kolonne A til C ret til aktuel, eller sig til hvis jeg skal gøre det
Sad længe og rodede rundt i Excel 2008 på min Mac, indtil jeg læste et sted at Excel 2008 for Mac ikke længere understøtter VBscript men kun Applescript.....
Så nu har jeg det inde i Excel 2008 på Windows.
Det virker for så vidt, bortset fra at den gentager Kolonne A 3 gange i stedet for at tage de andre kolonner.. Jeg kan ikke helt gennemskue scriptet så jeg selv kan rette det, er det muligt at du kan lave en lille forklaring og/eller rette det til så det er kolonnerne: A, B og H der indlæses i samlearket?
Sub samle() Set dest = Sheets("Ark1") dest.Range("A1:H10000") = "" ' sletter gl værdier For Each sh In ThisWorkbook.Sheets If sh.Name <> dest.Name Then dest.Cells(dest.Cells(65500, "A").End(xlUp).Offset(2, 0).Row, "A") = sh.Name rk = sh.Cells(65500, "A").End(xlUp).Row + 1 rk2 = dest.Cells(65500, "A").End(xlUp).Row + 1 x = sh.Range("A1:B" & rk) dest.Range("A" & rk2 & ":B" & rk2 + rk - 1) = x y = sh.Range("H1:H" & rk) dest.Range("H" & rk2 & ":H" & rk2 + rk - 1) = y End If Next 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.
