Hi Robert,

eine Möglichkeit: lege dein Protokoll als Druckbereich (ohne die Buttons) fest und dann kannst du diesen Code verwenden

Sub kopieren()  Range(ThisWorkbook.Worksheets("Tabelle1").PageSetup.PrintArea).Copy
    Workbooks.Add
    ActiveSheet.Paste
End Sub

andere Möglichkeit: du schreibst anstelle des Druckbereichs den von dir festgelegten Bereich mit deinem Protokoll

Worksheets("Tabelle1").Range("A1:F22").Copy

Bis später,
Karin

Hallo und Danke Karin, das mit dem Kopieren funktioniert! Nur sind in der neu angelegten Mappe die Spaltenbreiten nicht die selben als in der Vorlage.

außerdem schaut mein derzeitiges speichermakro so aus :-)

--snip-- Code

Sub Speichern_unter()
Dim Neuer_Dateiname

If Sheets("Messkreis-Prüfblatt").Range("F3") = "" Then MsgBox ("INFO: Anlagenkennzeichen ausfüllen!"): Exit Sub
If Sheets("Messkreis-Prüfblatt").Range("F4") = "" Then MsgBox ("INFO: Systembezeichnung ausfüllen!"): Exit Sub
If Sheets("Messkreis-Prüfblatt").Range("D18") = "" Then MsgBox ("INFO: Physikalische Vorgabewerte ausfüllen!"): Exit Sub
If Sheets("Messkreis-Prüfblatt").Range("D19") = "" Then MsgBox ("INFO: Physikalische Vorgabewerte ausfüllen!"): Exit Sub
If Sheets("Messkreis-Prüfblatt").Range("D20") = "" Then MsgBox ("INFO: Physikalische Vorgabewerte ausfüllen!"): Exit Sub
If Sheets("Messkreis-Prüfblatt").Range("D21") = "" Then MsgBox ("INFO: Physikalische Vorgabewerte ausfüllen!"): Exit Sub
If Sheets("Messkreis-Prüfblatt").Range("D22") = "" Then MsgBox ("INFO: Physikalische Vorgabewerte ausfüllen!"): Exit Sub
If Sheets("Messkreis-Prüfblatt").Range("D23") = "" Then MsgBox ("INFO: Physikalische Vorgabewerte ausfüllen!"): Exit Sub
If Sheets("Messkreis-Prüfblatt").Range("L62") = "" Then MsgBox ("INFO: Ersteller ausfüllen!"): Exit Sub
If Sheets("Messkreis-Prüfblatt").Range("P62") = "" Then MsgBox ("INFO: Stand ausfüllen!"): Exit Sub

Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:="C:\Vorlagen" & Format(Now, "YYYY-MM-DD ") & Cells(3, 6).Text & " Vorlage", fileFilter:="Excel-Arbeitsmappe, *.xls")
If Neuer_Dateiname = False Then Exit Sub
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname
End Sub
---snip --- Code

der Anfang ist zu vernachlässigen, dort frage ich lediglich ab ob gewissen Zellen befüllt sind oder nicht. Danach gebe ich meiner zu speichernden Datei einen definierten Namen Datum und die Überschrift einer Zelle.

Also wenn das mit dem kopieren so funktionieren würde, dass er mir auch gleich danach fragt wo ich das speichern sollte und die Spaltenbreite gleich wie in der Vorlage ist wäre das natürlich super.
Oder hast du (oder wer anderer) eine bessere Idee??

Lg Robert

Hi Robert,

- Abfrage zum Speichern: du könntest z.B. den Pfad in eine Zelle der Tabelle schreiben und von dort auslesen oder das Ganze mit einer Inputbox machen.

- zur Spaltenbreite: zeichne diesen Teil mit dem Makrorecorder auf und ergänze den Codeteil ActiveSheet.Paste damit.

Bis später,
Karin

Hallo Beverly(Karin)

danke nochmal für die schnelle Antwort!
Hat auch sehr gut funktioniert!
Mein Makro sieht in der zwischenzeit so aus:

------------Code Anfang-----------

Sub kopieren()

Range(ThisWorkbook.Worksheets("Messkreis-Prüfblatt").PageSetup.PrintArea, [A1:R63]).Copy
Workbooks.Add
ActiveSheet.Paste
Rows("1:2").Select
Selection.RowHeight = 12.5
Rows("3:3").Select
Selection.RowHeight = 16
Rows("4:63").Select
Selection.RowHeight = 12.5
Columns("A:A").Select
Selection.ColumnWidth = 0.9
Columns("B:R").Select
Selection.ColumnWidth = 4.9

ActiveSheet.PageSetup.PrintArea = "A1:R63"
ActiveSheet.PageSetup.LeftMargin = Application.CentimetersToPoints(1.3)
ActiveSheet.PageSetup.RightMargin = Application.CentimetersToPoints(0.5)
ActiveSheet.PageSetup.TopMargin = Application.CentimetersToPoints(1)
ActiveSheet.PageSetup.BottomMargin = Application.CentimetersToPoints(1)
ActiveSheet.PageSetup.HeaderMargin = Application.CentimetersToPoints(1.3)
ActiveSheet.PageSetup.FooterMargin = Application.CentimetersToPoints(0.6)


Dim Neuer_Dateiname
Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:="G:\TEAM\KKU\TEL-W\Technik\" & Format(Now, "YYYY-MM-DD ") & "Vorlage " & Cells(3, 6).Text, fileFilter:="Excel-Arbeitsmappe, *.xls")
If Neuer_Dateiname = False Then Exit Sub
ActiveSheet.PageSetup.CenterFooter = "&9&Z&F"
ActiveWorkbook.SaveAs Filename:=Neuer_Dateiname
End Sub

------------Code Ende-----------
Jetzt hätte ich noch eine Frage, wie bekomme ich Tabelle 3 auch gleichzeitig kopiert??
mit dem Bereich [A1:N42]

Lg Robert

Hi Robert,

ab Excel2002 kannst du das Kopieren der Spaltenbreite (aber nur dieser, nicht jedoch der Zeilenhöhe) mit diesem Code noch vereinfachen, da brauchst du nicht jede Spalte extra auslesen:

Selection.PasteSpecial Paste:=xlPasteColumnWidths

Diese Zeile musst du nach ActiveSheet.Paste einfügen.

Wenn du den Bereich aus Tabelle3 auch kopieren möchtest, dann ist die Frage - wohin? In eine andere Tabelle oder dieselbe?
Vom Prinzip her brauchst du das Kopieren nur vor den Speicherteil einbauen.

Bis später,
Karin

PS: in VBA kann zu 99% auf Select und Activate verzichtet werden. Den Teil zum Ändern der Zeilenhöhe und Spaltenbreite kannst du so verkürzen

Rows("1:2").RowHeight = 12.5
Rows("3:3").RowHeight = 16
Rows("4:63").RowHeight = 12.5
Columns("A:A").ColumnWidth = 0.9
Columns("B:R").ColumnWidth = 4.9

Hallo Karin,

bezüglich kopieren war mir klar, dass es vor Aufruf Neuer Dateinamen stehen muss. Doch nach Aufruf von
-------- Code Anfang------
Workbooks.Add
ActiveSheet.Paste
-------- Code Ende------
des Scripts wird automatisch eine neue Mappe erstellt, wo die Kopie des Originals in Tabelle 1 kopiert ist. Füge ich nun ein kopieren der Tabelle 3 des Originals aus weiß er ja nicht mehr woher er die Tabelle 3 nehmen soll, weil jetzt "ThisWorkbook.Worksheets" ja nun die neue Mappe ist!
zb.:
-------- Code Anfang------
Sub kopieren()

Range(ThisWorkbook.Worksheets("Messkreis-Prüfblatt").PageSetup.PrintArea, [A1:R63]).Copy
Range(ThisWorkbook.Worksheets("Tabelle3").PageSetup.PrintArea, [A1:N42]).Copy
Workbooks.Add
ActiveSheet.Paste
...
-------- Code Ende------
INFO: Messkreis-Prüfblatt = Tabelle1

Wie muss ich diese Zeile anpassen das er mir nicht nur Tabelle 1 sonder auch Tabelle 3 mit einem bestimmten Range in die neue Mappe gleichzeitig kopiert?

Lg Robert

Hi Robert,

du hast dich leider nicht dazu geäußert, wo der 2. Bereich hinkopiert werden soll, weshalb er einfach unter den ersten Bereich angefügt wird

Sub kopieren()
    Application.ScreenUpdating = False
    Workbooks.Add
    With ActiveWorkbook
        ThisWorkbook.Worksheets("Messkreis-Prüfblatt").Range("A1:R63").Copy
        ActiveSheet.Paste
        ThisWorkbook.Worksheets("Tabelle3").Range("A1:N42").Copy
        Range("A64").Select
        ActiveSheet.Paste
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Bis später,
Karin

Hallo Karin,
danke für die schnelle Antwort.
werde versuchen, mein Fragen besser auszubauen. :-)
Es funktioniert alles sehr gut, nur das ich eben Tabelle 3 vom Orginal wieder in Tabelle3 der Kopie pasten möchte. Und nicht so wie jetzt Tabelle 3 vom Orginal in Tabelle1 der Kopie kopiert wird. :-)

kann man beim pasten angeben in welches Tabellenblatt kopiert werden soll?

glg Robert

Hi Robert,

je, eine genaue Aufgabenbeschreibung hilft außerordentlich :-).
Versuches es hiermit

Sub kopieren()
    Dim inTabellen As Integer
    Application.ScreenUpdating = False
    Workbooks.Add
    With ActiveWorkbook
        ThisWorkbook.Worksheets("Messkreis-Prüfblatt").Range("A1:R63").Copy
        ActiveSheet.Paste
        If .Worksheets.Count < 3 Then
            Worksheets.Add Count:=3 - .Worksheets.Count, after:=Sheets(Worksheets.Count)
        Else
            .Worksheets("Tabelle3").Select
        End If
        ThisWorkbook.Worksheets("Tabelle3").Range("A1:N42").Copy
        ActiveSheet.Paste
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Bis später,
Karin