Halllo zusammen,

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