17. december 2004 - 08:01Der er
10 kommentarer og 1 løsning
Optimering af makro - der danner nye ark på grundlag af liste/ark
Hej
Jeg har tidligere fået hjælp til denne makro.
Makroen danner nye ark (kopi af indhold fra et andet ark), samt sætter indhold ind i arkene, udfra en liste.
Den tager meget lang tid at gennemføre!!!!!!!
Jeg mener det bla skyldes, at i hvert nyt ark defineres sideopsætningen, samt evt at den opdatere hver gang. Måske kan indhold til arkene - sættes smartere ind.
Håber på nogle gode ideer og input!!!
Den ser således ud:
Sub DanArk() Application.ScreenUpdating = False Sheets("Ark1").Select Dim c As Range For Each c In Range("B1", Range("B1").End(xlDown)) Sheets("Ark2").Activate Cells.Copy Worksheets.Add(after:=Worksheets("Ark2")).Name = c.Value ActiveSheet.Paste Application.CutCopyMode = False Range("A1") = c.Offset(0, 1).Value Range("B1") = c.Offset(0, 2).Value Range("C1") = c.Offset(0, 3).Value Range("D1") = c.Offset(0, 4).Value Range("E1") = c.Offset(0, 5).Value Range("F1") = c.Offset(0, 6).Value Range("G1") = c.Offset(0, 7).Value Range("H1") = c.Offset(0, 8).Value Range("I1") = c.Offset(0, 9).Value Range("J1") = c.Offset(0, 10).Value Range("K1") = c.Offset(0, 11).Value Range("L1") = c.Offset(0, 12).Value Range("M1") = c.Offset(0, 13).Value With ActiveSheet.PageSetup .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.59) .RightMargin = Application.InchesToPoints(0.59) .TopMargin = Application.InchesToPoints(1#) .BottomMargin = Application.InchesToPoints(1#) .PrintArea = "$A$2:$I$45" End With Range("A2").Select Next Sheets("Ark2").Activate Application.ScreenUpdating = True
Sub DanArk() Application.ScreenUpdating = False Sheets("Ark1").Select Dim c As Range For Each c In Range("B1", Range("B1").End(xlDown)) Sheets("Ark2").Activate Cells.Copy Worksheets.Add(after:=Worksheets("Ark2")).Name = c.Value ActiveSheet.Paste Application.CutCopyMode = False Range("A1:M1") = Range(c.Offset(0, 1), c.Offset(0, 13)).Value
With ActiveSheet.PageSetup .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.59) .RightMargin = Application.InchesToPoints(0.59) .TopMargin = Application.InchesToPoints(1#) .BottomMargin = Application.InchesToPoints(1#) .PrintArea = "$A$2:$I$45" End With
Range("A2").Select Next Sheets("Ark2").Activate Application.ScreenUpdating = True Range("A2").Select Sheets("Ark3").Select End Sub
det er din sideopsætning der tager tid den kan jeg ikke optimere
Jeg har lavet om, så hvis du laver side opsætning og print område i Ark2, kopierer den her hele arket, så kommer opsætningen med automatisk
Sub DanArk() Application.ScreenUpdating = False Sheets("Ark1").Select Dim c As Range For Each c In Range("B1", Range("B1").End(xlDown)) Sheets("Ark2").Select Sheets("Ark2").Copy Before:=Sheets(2) ActiveSheet.Name = c.Value Application.CutCopyMode = False Range("A1:M1") = Range(c.Offset(0, 1), c.Offset(0, 13)).Value Range("A2").Select Next Sheets("Ark2").Activate Application.ScreenUpdating = True Range("A2").Select Sheets("Ark3").Select End Sub
Hold da op! Tusind tak for input. Jeg kan desværre ikke nå at arbejde med det i dag. Jeg kikker på det i morgen. Jeg vil glæde mig til at kikke på det - det ser godt ud.
Jeg har testet den sidste. Den fungerer fint ved meget få rækker i Ark1-Kolonne B (under 10). Ved større antal rækker (ca 30) kommer den frem med en debug ved linien -
Sheets("Ark2").Copy Before:=Sheets(2). Fejlmeddelelse: Metoden Copy for klassen worksheet mislykkes.
Rækken/arket den stopper ved har ikke specielle oplysninger eller lign.
Den har ellers en fantastisk hastighed i forhold til før.
Jeg kan få den til at virke til ark nr. 37, jeg kan ikke se, hvad der sker. Jeg tror, at jeg må bygge projektmappen op fra bunden igen. Der er noget, der driler.
jeg har testet denne med 200 ark, det tager 18 sek.
Sub DanArk() Application.ScreenUpdating = False Sheets("Ark1").Select Dim c As Range For Each c In Range("B1", Range("B1").End(xlDown)) Sheets("Ark2").Copy after:=Sheets(2) ActiveSheet.Name = c.Value Range("A1:M1") = Range(c.Offset(0, 1), c.Offset(0, 13)).Value Next Application.ScreenUpdating = True Sheets("Ark3").Select 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.
