Namen automatisch vergeben aufgrund Tabellennamen
30.07.2015 08:20:09
Jason
In einem Tabellenblatt habe ich 12 Spalten (A:L). In der Spalte J steht jeweils der Name des Projektleiters. Mit folgendem Makro werden die Daten gefiltert und automatisch ein separates Tabellenblatt pro Projektleiter erstellt. Anschliessend habe ich die Wahl, ob ich jedes Tabellenblatt als separate Datei speichern möchte:
Sub Verteilen_auf_PL()
Dim rng1 As Range, rng2 As Range
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
Set rng2 = .Cells(1, 10)
.Sort key1:=rng2, order1:=xlAscending, Header:=xlYes
Do
Set rng1 = rng2.Offset(1, 0)
If rng1.Value = "" Then Exit Do
Set rng2 = rng1.EntireColumn.Find(What:=rng1.Value, searchdirection:=xlPrevious, _
LookAt:=xlWhole, LookIn:=xlValues)
Sheets.Add after:=Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Name = rng1.Value
.Rows(1).Copy ActiveSheet.Cells(1, 1)
Range(rng1, rng2).EntireRow.Copy ActiveSheet.Cells(2, 1)
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2").Select
Loop
End With
Sheets(1).Select
a = MsgBox("Die Projekte wurden gefiltert und pro Projektleiter in ein separates _
Tabellenblatt kopiert. Möchten Sie alle Tabellenblätter separat speichern?", vbYesNo, "Verteilung beendet")
If a = vbNo Then Exit
Sub Else
For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(i).Copy
ActiveWorkbook.SaveAs Sheets(1).Name
ActiveWorkbook.Close
Next
End Sub
Nun möchte ich, bevor ich die Wahl habe die Tabellenblätter als separate Dateien zu speichern, dass jeweils der Bereich A:L sämtlicher Tabellenblätter automatisch aufgrund des Tabellennamens benannt werden.
Kann mir jemand helfen, dies zu realisieren bitte?
Vielen Dank und Grüsse
Jason