VBA Code für kopieren von Tabellenblätter in NEUES Excel- Dok

[CHASiN1994]

Moin Moin liebe VBA´ler,

ich bin auf der Suche nach einem VBA Code, um aus einer Masterrechnungsdatei jeweils pro KW ein neues Excel Dokument zu erstellen, dass immer drei Tabellenblätter kopiert und dort einfügt.

In meiner beigefügten Datei sind 4 Tabellenblätter. 

1. Es soll nun eine neue Excel- Mappe erstellt werden, die "KW"& Zelle G1 aus Tabellenblatt Rechnung heißt.
2. sollen 3 Tabellenblätter (Rechnung, 1418, 1419) davon jeweils komplett, nur Werte in diese Excel- Mappe als eigenständige Tabellenblätter mit den Namen aus der Masterdatei eingefügt werden.

Diese Excel Mappe soll natürlich in unserem Poolordner gespeichert werden. Den Pfad usw. kann ich später ändern. 
Anschließend werde ich noch diese Mappe per Makro an einen Mail- Verteiler senden. Das kriege ich auch selber hin.

Also bitte zunächst Punkt 1 und 2. dann wäre ich euch schon sehr dankbar. 


MfG 
Tobi

[Egon12]

Hallo Tobi,

so auf die Schnelle zu Punkt 1

Code:

Option Explicit

Sub SaveAs_KW()

    Dim Pfad$, Datei$, Filter$, Endg$, File
   
    Datei = "KW " & Worksheets("Rechnung").Range("G2")
    If Datei = "" Then
        MsgBox "Gib bitte einen Dateinamen an!", vbExclamation
        Exit Sub
    End If
    Endg = ".xlsm"
    If InStr(Datei, Endg) = 0 Then
        Datei = Datei & Endg
    End If
    Filter = "Excel Files (*" & Endg & "), *" & Endg
    File = Application.GetSaveAsFilename(Pfad & Datei, Filter)
    If File <> False Then ActiveWorkbook.SaveAs Filename:=File
End Sub

Damit speichert man erst mal die komplette Datei als "KW 1.xlsm"

zu 2. brauche ich weitere Infos

Welcher Inhalt soll kopiert werden?
- Sheet Name und Bereich von bis

z.B.
       Sheet: "notwendige Daten" Range("F1:G3")
       Sheet: "Rechnung" Range("A1:B27")
u.s.w.
Mit den Infos kann ich den fehlenden noch zusammen stellen.

Gruß Uwe

[CHASiN1994]

Hi Uwe,

danke schonmal.

ich dachte das wäre mit meinem geschriebenen Thread ersichtlich.

also so:

 Sheet: "Rechnung" Range("A1:L10000")
 Sheet: "1418" Range("A1:L10000")
 Sheet: "1419" Range("A1:L10000")

[Egon12]

Letzte Frage:

Du hattest geschrieben, dass nur Werte in den jeweiligen Sheets mitgegeben werden sollen. Sollen die Formel in "notwendige Daten" raus oder können die drin bleiben und sollen die Formatierungen (Rahmen etc.) bleiben?

[Egon12]

Hallo Tobi,

ich habe mal was zusammengestellt. Ich hoffe es richtig erfasst zu haben.

Code:

Option Explicit

Sub Datensicherung_KW()
    Dim strFilename As String, strFilenameM As String

'******************* Anpassungen falls nötig ************************
        strFilename = "KW " & Worksheets("Rechnung").Range("G2")
'********************************************************************
        strFilenameM = ThisWorkbook.Name

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheets("Rechnung").Range("A1:L1000").Copy
    Workbooks.Add
        ActiveWindow.Caption = strFilename
        Windows(strFilename).Activate
        With ActiveSheet
            .Name = "Rechnung"
            .Paste
        End With
    Range("A:A").ColumnWidth = 19.86
    Range("B:B").ColumnWidth = 15.68
    Cells(1, 1).Select
    Worksheets.Add
        Windows(strFilenameM).Activate
        Sheets("1418").Range("A1:L1000").Copy
        Windows(strFilename).Activate
        With ActiveSheet
            .Name = "1418"
            .Paste
        End With
    Range("A:A").ColumnWidth = 9.43
    Range("B:B,C:C,D:D").ColumnWidth = 14.14
    Range("E:E").ColumnWidth = 7.14
    Cells(1, 1).Select
    Worksheets.Add
    Windows(strFilenameM).Activate
    Sheets("1419").Range("A1:L1000").Copy
    Windows(strFilename).Activate
        With ActiveSheet
            .Name = "1419"
            .Paste
        End With
    Range("A:A").ColumnWidth = 10.71
    Range("B:B").ColumnWidth = 14.14
    Cells(1, 1).Select
    Sheets("Rechnung").Activate
    Application.ScreenUpdating = True

    With Application.FileDialog(msoFileDialogSaveAs)
        .FilterIndex = 1 'Filterindex 1 ist .xlsx und 2 ist .xlsm
        .InitialFileName = strFilename
        If .Show = -1 Then
            .Execute
        Else
            MsgBox "Es wurde Abbrechen gedrückt!"
        End If
    End With
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub

Vielleicht noch ein kleiner Gedanke. Wir nutzen diese Plattform kostenlos. Hinter diesem Forum steckt ein Verein, der wenn dir der Mehrwert gefällt, sich vielleicht über eine kleine Spende freuen wird (siehe unter Excel-Verein). Für mich ist das nur ein Hobby auf diesen Plattformen in meiner Freizeit was für andere zu tun. Beruflich habe ich überhaupt nichts mit Programmieren zu tun.

Gruß Uwe

[CHASiN1994]

Moin Uwe,

Hey ich bin dir sehr dankbar für deine Unterstützung. Generell bin ich recht oft hier im Forum und schaue auch andere Threads und versuche bei Formeln zu helfen. Ich brauche meist Hilfe bei VBA vom Groben. Die Detailsarbeit kann ich dann auch durchführen (nachdem ich oft hierher gekommen bin und Fragen gestellt habe).

anbei mein Kompletter Code

Code:

Option Explicit

Sub Rechnung_speichern()
    Dim strFilename As String, strFilenameM As String

        strFilename = "KW " & Worksheets("Rechnung").Range("I1")

        strFilenameM = ThisWorkbook.Name

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheets("Rechnung").Range("A1:E1000").Copy
    Workbooks.Add
        ActiveWindow.Caption = strFilename
        Windows(strFilename).Activate
        With ActiveSheet
            .Name = "Rechnung"
            .Range("A1").PasteSpecial Paste:=xlPasteFormats
            .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Application.CutCopyMode = False
        End With
    Range("A:A").ColumnWidth = 20
    Range("B:B").ColumnWidth = 20
    Range("C:C").ColumnWidth = 15
    Range("D:D").ColumnWidth = 15
    Range("E:E").ColumnWidth = 20
    Cells(1, 1).Select
    Worksheets.Add
        Windows(strFilenameM).Activate
        Sheets("6500001").Range("A1:L1000").Copy
        Windows(strFilename).Activate
        With ActiveSheet
            .Name = "6500001"
            .Range("A1").PasteSpecial Paste:=xlPasteFormats
            .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
   
            Application.CutCopyMode = False
        End With
    Range("A:A").ColumnWidth = 9.43
    Range("B:B,C:C,D:D").ColumnWidth = 14.14
    Range("E:E").ColumnWidth = 7.14
    Cells(1, 1).Select
    Worksheets.Add
    Windows(strFilenameM).Activate
    Sheets("6500006").Range("A1:L1000").Copy
    Windows(strFilename).Activate
        With ActiveSheet
            .Name = "6500006"
            .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        End With
    Range("A:A").ColumnWidth = 10.71
    Range("B:B").ColumnWidth = 14.14
    Cells(1, 1).Select
    Sheets("Rechnung").Activate
    Application.ScreenUpdating = True

Worksheets("Tabelle2").Delete
Worksheets("Tabelle3").Delete
ActiveWorkbook.SaveAs Filename:="F:\unknown\2021\Excel\" & strFilename & ".xlsx"

End Sub

Grüße gehen raus!