Tabellenblätter in Schleife in neue Arbeitsmappe verschieben und speichern
06.12.2019 10:47:47
Dominic
mit dem nachfolgenden Code lasse ich mit einer Schleife kundenspezifische Daten in ein vorbereitetes Formular einlesen (das Einlesen geht im Formular über SVerweis), je Kunde ein neues Tabellenblatt mit seinen spezifischen Inhalten anlegen und mit dem Namen des Kundenprojekts benennen.
Mein Ziel ist, jedem Kunden jeweils nur sein Formular (als Excel-Datei) zukommen zu lassen. Also suche ich eine Funktion in der Schleife, um
- jedes neu erzeugte Tabellenblatt in eine neue, eigene Arbeitsmappe mit nur diesem Blatt als Inhalt zu verschieben
- das Tabellenblatt mit (für alle gleichem) Passwort zu schützen und zu sperren
- diese Arbeitsmappe jeweils mit dem Namen des Tabellenblatts abzuspeichern,
bis zum Ende der Schleife.
So sollen am Ende ca. 50 Arbeitsmappen erzeugt werden (im Code unten testweise nur 5).
Kann mir dabei jemand helfen?
Nun der bisherige Code, den ich mangels VBA-Vorkenntnissen aus diversen Quellen und Makro- _
Aufzeichnungen zusammengebastelt habe (soweit funktioniert er schon! :)).
Sub AutoCopyBlaetter()
' Befüllt Zelle AG6 mit Zahl aus Schleife
' Kopiert dann Tabellenblatt
' benennt dann Tabellenblatt nach Inhalt U28
' Tastenkombination: Strg+t
Dim dValue As Integer
Dim wsAlle As Worksheet
Dim wsNeu As Worksheet
Dim strName As String
Dim Pleft As Double, Ptop As Double
For dValue = 1 To 5
Sheets("Tabelle1").Range("AG6").Value = dValue
strName = Worksheets("Tabelle1").Range("u28").Value
Sheets("Tabelle1").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = strName
Sheets("Tabelle1").Shapes("Picture 1").Copy
Ptop = Sheets("Tabelle1").Shapes("Picture 1").Top
Pleft = Sheets("Tabelle1").Shapes("Picture 1").Left
Sheets(strName).Paste
Sheets(strName).Shapes("Picture 1").Left = Pleft
Sheets(strName).Shapes("Picture 1").Top = Ptop
Sheets(strName).Range("A19:AD38").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("AG:AG").Select
Range("AG16").Activate
Selection.EntireColumn.Hidden = True
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingRows:=True
Next dValue
End Sub
Vielen Dank für Eure Tipps!
Grüße
Dominic
