Sheet kopieeren zonder de macro

[snb]

Een kwestie van consistentie:
Als bij het kopiëren van hele kolommen ook de kolomopmaak wordt gekopieerd, zal dat ook wel het geval zijn met rijen.

Sub Savetest()
  With Workbooks.Add
     With .Sheets(1)
       ThisWorkbook.Sheets("Bestellijst1").Range("A:AB").Copy .[A1]
       ThisWorkbook.Sheets("Bestellijst1").Range("[COLOR="Teal"]1:24[/COLOR]").Copy .[A1]
      .Parent.SaveAs "P:\Bestellijsten\Bestellijsten\" & .[R7] & " " & .[U9] & " " & .[R6] & Format(Date, " dd-mm-yyyy") & ".xls"
    End With
    .Close
  End With
End Sub

 

[HWV]

Weer een stap verder

Sub Savetest()
  With Workbooks.Add
     With .Sheets(1)
       ThisWorkbook.Sheets("Bestellijst1").Range("A:AB").Copy .[A1]
       ThisWorkbook.Sheets("Bestellijst1").Range("1:500").Copy .[A1]
         For Each sh In ActiveWorkbook.Worksheets
    With sh.PageSetup
      .TopMargin = Application.CentimetersToPoints(2)
      .BottomMargin = Application.CentimetersToPoints(2)
      .LeftMargin = Application.CentimetersToPoints(1.5)
      .RightMargin = .LeftMargin
    End With
  Next
      Dim lLaatsteRegel As Long
    
    lLaatsteRegel = Range("A" & Rows.Count).End(xlUp).Row
    
    ActiveSheet.PageSetup.PrintArea = Range("A170:AB" & lLaatsteRegel).Address(1, 2)
      .Parent.SaveAs "P:\Bestellijsten\Bestellijsten\" & .[R7] & " " & .[U9] & " " & .[R6] & Format(Date, " dd-mm-yyyy") & ".xls"
    End With
    .Close
  End With
End Sub

Hij heeft nu inderdaad de kolom en de rij opmaak meegenomen, maar kan enkel niet enkel kolom A:AB kopieeren. Afzonderlijk enkel alleen de kolom dan pakt hij wel de kolomen maar samen met de rijen pakt hij de hele sheet maar wel met opmaak.

Ik heb er nu de marge`s van de sheet ingesteld en een print area.

Ik heb twee vragen nog hierover die tot nu toe boven water zijn gekomen.

1) Ik wil er ook nog een footnote aan toevoegen, die dan op elke pagina wordt weergegeven.
2) Ik heb nu een print bereik vast gesteld , maar het liefst wil ik dat hij enkle de kolomen A t/ AB print, en dan tot de laatst gevulde regel.

Is dit wel mogelijk

Groet Henk

 

[HWV]

Sub Savetest2()
  With Workbooks.Add
     With .Sheets(1)
       ThisWorkbook.Sheets("Bestellijst1").Range("A:AB").Copy .[A1]
       ThisWorkbook.Sheets("Bestellijst1").Range("1:500").Copy .[A1]
         For Each sh In ActiveWorkbook.Worksheets
        With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$18"
    End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$AB$146"
    With ActiveSheet.PageSetup
        .CenterFooter = _
        "&8 Regel 1 FOOTER" & Chr(10) & "&7Regel 2 FOOTER" & Chr(10) & " Regel 3 FOOTER"
        .RightFooter = "Blad &P van &N"
        .TopMargin = Application.CentimetersToPoints(1)
        .BottomMargin = Application.CentimetersToPoints(2)
        .LeftMargin = Application.CentimetersToPoints(1.5)
        .RightMargin = .LeftMargin
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.393700787401575)
    End With
  Next
      Dim lLaatsteRegel As Long
    
    lLaatsteRegel = Range("A" & Rows.count).End(xlUp).Row
    
    ActiveSheet.PageSetup.PrintArea = Range("A170:AB" & lLaatsteRegel).Address(1, 2)
    Columns("AC:AO").Delete
      .Parent.SaveAs "P:\Bestellijsten\Bestellijsten\" & .[R7] & " " & .[U9] & " " & .[R6] & Format(Date, " dd-mm-yyyy") & ".xls"
    End With
    .Close
  End With
End Sub

Dit is de code hoe ik hem tot nu toe heb gemaakt, hij kan zeker geoptimaliseerd worden, maar zou nu niet weten hoe ik dit zou moeten doen.

Hij kopieer de sheet naar een nieuw blad, en slaat hem op met de namen wat er in de cellen R7 U9 R6 zijn ingevuld.
Ik heb het voor elkaar gekregen om een footer er in te plaatsen en tevens de pagina instellingen, zodat de marge geplaats worden en dat er op elke pagina een kophoofd meegenomen wordt

   Dim lLaatsteRegel As Long
    
    lLaatsteRegel = Range("A" & Rows.count).End(xlUp).Row
    
    ActiveSheet.PageSetup.PrintArea = Range("A170:AB" & lLaatsteRegel).Address(1, 2)

Voor de print instellingen heb ik volgens mij twee keer gedefineerd, de bovenstaande code doet niet wat het moet doet, volgens mij moet hij kijken naar de laatste gevulde regel en gebruik dit als print area. Maar volgens mij heb ik dus nu twee print area`s gemaakt.

Kan iemand mij "Helpmij.nl" om dit optimaliseren.

Groet Henk

 

[snb]

Als je meer dan 1 werkboek open hebt: verwijs in je code altijd naar het werkboek waarin iets moet gebeuren.
Als je meer dan 1 werkblad in een werkboek hebt: verwijs in je code altijd naar het werkblad waarin iets moet gebeuren.
En maak nooit gebruik van Select, Activate, Activeworkbook, Activesheet, Activecell.

Voorbeeld:
c0=workbooks(1).sheets(2).range("A10')

 

[HWV]

Code

c0=workbooks(1).sheets(2).range("A10')

Beste SNB,

Bedankt voor de reactie.

[COLOR="Red"]c0=[/COLOR]workbooks(1).sheets(2).range("A10')

Als ik de code gaat ontleden om het te kunnen snappen, dan kom ik een heel end maar het rode gedeelt kan ik niet begrijpen

Ik gebruik de laatset tijd veel deze code :

Workbooks("Partyvoorraad .xls").Sheets("13").Range("A4:A4500").Copy
    Workbooks("Partyvoorraad Dymasys.xls").Sheets("PartyVoorraad").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues

Maar daar gebruik het rode gedeelt in uw antwoord niet

Groet Henk

ps,
Is dit iets wat ik nu in mijn code kan gebruiken?, als dit zo is zou ik niet weten waar

 

[Warme bakkertje]

Probeer 'm zo eens

Sub Savetest2()
Dim sh As Worksheet, lLaatsteRegel As Long
  With Workbooks.Add
     With .Sheets(1)
       ThisWorkbook.Sheets("Bestellijst1").Range("A:AB").Copy .[A1]
       ThisWorkbook.Sheets("Bestellijst1").Range("1:500").Copy .[A1]
        lLaatsteRegel = .Range("A" & Rows.Count).End(xlUp).Row
        With .PageSetup
            .PrintTitleRows = "$1:$18"
            .CenterFooter = _
            "&8 Regel 1 FOOTER" & Chr(10) & "&7 Regel 2 FOOTER" & Chr(10) & " Regel 3 FOOTER"
            .RightFooter = "Blad &P van &N"
            .TopMargin = Application.CentimetersToPoints(1)
            .BottomMargin = Application.CentimetersToPoints(2)
            .LeftMargin = Application.CentimetersToPoints(1.5)
            .RightMargin = .LeftMargin
            .HeaderMargin = Application.InchesToPoints(0.511811023622047)
            .FooterMargin = Application.InchesToPoints(0.393700787401575)
            .PrintArea = Range("A1:AB" & lLaatsteRegel).Address(1, 2)
        End With
        Columns("AC:AO").Delete
        .Parent.SaveAs "P:\Bestellijsten\Bestellijsten\" & .[R7] & " " & .[U9] & " " & .[R6] & Format(Date, " dd-mm-yyyy") & ".xls"
    End With
    .Close
  End With
End Sub

Mvg

Rudi

 

[HWV]

Perfect

Rudi,

Bedankt weer voor jou bijdrage.

Werkt nu perfect, moest enkel voor mijn sheet de kolom aanpassen en zorgen dat de eerste 18 regels gevuld zijn maar dit is gelukt en werkt nu naar behore.
Ik ben hier erg blij mee dat dit is gelukt.
Kan jij mij missichien vertellen wat

c0=workbooks(1).sheets(2).range("A10')

de c0= betekend in deze formule


Groet Henk