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
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
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")
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?
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
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!