Hallo Zusammen,
ich möchte eine große Vorlagedatei für verschiedene Benutzer anpassen und in verschiedenen Varianten abspeichern.
Die Benutzer benötigen alle eine andere Konstellation von Spalten. Diese habe ich in einer Matrix vorgegeben.
Problem: Ich habe eine Schleife gemacht, in der die geöffnete Vorlagedatei auf den ersten Nutzer angepasst wird. Dann soll sich diese neue Datei speichern und schließen und wieder die Vorlagedatei öffnen um nun die Version für Nutzer 2 zu erzeuegn usw.
Leider klappt das nur für Nutzer 1. Die Schleife macht keinen 2. Durchlauf.
Sub Alle_erzeugen()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim Selektion, Name, Pfad, Überschrift As String
Dim letzteSp, letzteZ, x, y, SpalteMitÜberschrift, AnzOrgs As Integer
With ThisWorkbook.Worksheets("Matrix")
AnzOrgs = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
letzteZ = .Cells(.Rows.Count, 1).End(xlUp).Row
letzteSp = .Cells(1, Columns.Count).End(xlToLeft).Column
End With
'#########################################################################################################################################################################################################
' Schleife 1 EK-Orgs
For x = 1 To AnzOrgs
With ThisWorkbook.Worksheets("Matrix")
Name = Application.WorksheetFunction.VLookup(.Cells(x + 1, 1), .Range(.Cells(2, 1), .Cells(letzteZ, letzteSp)), letzteSp - 1, False)
Pfad = Application.WorksheetFunction.VLookup(.Cells(x + 1, 1), .Range(.Cells(2, 1), .Cells(letzteZ, letzteSp)), letzteSp, False)
ThisWorkbook.SaveAs filename:=Pfad & Name, FileFormat:=xlOpenXMLWorkbook
'#########################################################################################################################################################################################################
' Schleife 2 Spalten der EK-Org
For y = letzteSp - 3 To 2 Step -1
If Application.WorksheetFunction.VLookup(.Cells(x + 1, 1), .Range(.Cells(2, 1), .Cells(letzteZ, letzteSp)), y, False) = "raus" Then
With ThisWorkbook.Worksheets("Matrix")
Überschrift = .Cells(1, y)
SpalteMitÜberschrift = Application.WorksheetFunction.Match(Überschrift, ThisWorkbook.Worksheets("Master Data Sheet").Range(ThisWorkbook.Worksheets("Master Data Sheet").Cells(10, 1), ThisWorkbook.Worksheets("Master Data Sheet").Cells(10, letzteSp - 4)), False)
ThisWorkbook.Worksheets("Master Data Sheet").Columns(SpalteMitÜberschrift).delete
ThisWorkbook.Worksheets("Prüfung").Columns(SpalteMitÜberschrift).delete
ThisWorkbook.Worksheets("Prüfung").Rows("1:7").ClearContents
End With
End If
Next y
'ende Schleife 2
'#########################################################################################################################################################################################################
ThisWorkbook.Worksheets("Master Data Sheet").Shapes.Range(Array("delete_entries")).delete
ThisWorkbook.Worksheets("Master Data Sheet").Shapes.Range(Array("Vollständigkeit")).delete
ThisWorkbook.Worksheets("SDB vom EK_LF").delete
ThisWorkbook.Worksheets("Matrix").delete
ThisWorkbook.Worksheets("Blaetter erzeugen").delete
If x < AnzOrgs Then
Workbooks.Open filename:="\\gh.de\dfs\gh-zen-FLDREDIR\Ottee\Desktop\Dezember\Master Data Sheet P&C from December_Test.xlsb"
Workbooks("Master Data Sheet P&C from December_Test.xlsb").Activate
End If
End With
Workbooks(Name).Save
Workbooks(Name).Close
Next x
'ende Schleife 1
'#########################################################################################################################################################################################################
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Was muss ich verändern, damit es klappt?
Vielen Dank im voraus,
MfG
Enrico
|