Erstellung von Mappen mit Namen aus einer Liste

Hallo zusammen,
ich habe mal wieder eine Frage:
ich habe eine Excelbasisdatei mit 2 Arbeitsblättern
Blatt 1 ist eine Liste mit folgenden Daten:
Spalte A: ID (laufende 3 Stellige Nummern)
Spalte B: Name (Namen)
Blatt 2 ist ein Musterarbeitsblatt mit Inhalt
Jetzt brauche ich ein Makro, welches mir in der selben Exceldatei nacheinander je ID ein zusätzliches Arbeitsblatt (als Kopie des Musterarbeitsblattes) erstellt (als Name genau die ID). Dabei müsste sichergestellt werden, dass keine ID aus der Liste 2x angelegt wird.
Nachdem ein Blatt kopiert und umbenannt wurde soll ein weiteres Makro aufgerufen werden. Dieses darf dann nur auf diesem Blatt auswirkungen kaben und nicht auf den anderen Kopien.
Ich hoffe ich habe mich verständlich ausgedrückt :)
Ich dake euch wie immer für eure tolle Hilfe vorab.
PS: schön wäre auch noch ein Makro zusätzlich, mit welchem ich alle Arbeitsblätter (außer der Ausgangsliste und dem Muster) wieder löschen kann. Aber daran probier ich mich sonst auch selber :) )

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Nachfrage

24.08.2016 22:13:48

ChrisL

AW: Nachfrage

24.08.2016 23:06:48

Christian

so...

25.08.2016 08:48:32

ChrisL

AW: so...

25.08.2016 21:35:13

Christian

AW: so...

26.08.2016 08:09:00

ChrisL

AW: so...

27.08.2016 08:21:23

ChrisL

AW: so...

27.08.2016 10:40:17

Christian

Sub Leerzeilen_ausblenden() Dim iRow As Long Dim iCol As Integer Dim lastRow As Long lastRow = ActiveSheet.Cells.Find("*", searchdirection:=xlPrevious).Row Application.ScreenUpdating = False Rows.EntireRow.Hidden = False For iRow = lastRow To 7 Step -1 If Cells(iRow, 14) = "" Then Rows(iRow).EntireRow.Hidden = True End If Next End Sub

Sub Mach() Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet Dim iZeile As Long, letzteZeile As Long Set WS1 = Worksheets("Liste") Set WS2 = Worksheets("Muster") Application.ScreenUpdating = False Call TBloeschen(WS1, WS2) letzteZeile = WS1.Cells(Rows.Count, 1).End(xlUp).Row For iZeile = 2 To letzteZeile If WorksheetFunction.CountIf(WS1.Range("A1:A" & iZeile), WS1.Cells(iZeile, 1)) = 1 Then WS2.Copy After:=Worksheets(Worksheets.Count) Set WS3 = ActiveSheet WS3.Name = WS1.Cells(iZeile, 1) Call Leerzeilen_ausblenden(WS3) End If Next iZeile WS1.Select End Sub

Private Sub TBloeschen(WS1 As Worksheet, WS2 As Worksheet) Dim WS As Worksheet Application.DisplayAlerts = False For Each WS In ThisWorkbook.Worksheets If WS.Name WS1.Name And WS.Name WS2.Name Then _ WS.Delete Next WS Application.DisplayAlerts = True End Sub

Private Sub Leerzeilen_ausblenden(WS As Worksheet) Dim iRow As Long Dim iCol As Integer Dim lastRow As Long lastRow = WS.Cells.Find("*", searchdirection:=xlPrevious).Row Application.ScreenUpdating = False WS.Rows.EntireRow.Hidden = False For iRow = lastRow To 7 Step -1 If WS.Cells(iRow, 14) = "" Then WS.Rows(iRow).EntireRow.Hidden = True End If Next End Sub

Hallo ChrisL,
Riesen Dank.
Das war nahezu perfekt.
ich hab es noch ein klitzekleines bisschen angepasst. Aber nur Schönheitsdinge.
Hab eine Steuerungsseite eingefügt.
Ich habe jetzt den Namen der Arbeitsmappe einfach in die Zelle B5 übergeben. Weil es mit der Formel nicht funktionierte (es war immer der Name der letzten erstellen Arbeitsmappe in allen Arbeitsmappen in Zelle B5.
Aber mit der direkten übergabe ist es sauberer :)
Für den Sverweis benötige ich ein Suchkriterium, welches ich in der Datenbasis-Datei wiederfinde. und das ist diese ID in Verbindung mit den Nummern in Spalte A und B.
Klappt alles super.
2 Dinge wäre jetzt noch das "I-Tüpfelchen"
1. nach dem erstellen der Arbeitsmappe wird der Name der Arbeitsmappe umbenannt. Danach übertragen die SVERWEIS-Formeln alles automatisch. Ich müsste jetzt nur noch mit einer Codezeile Quasi "alles markieren, Inhalte einfügen" damit nur die Werte im Endergebnis stehen und keine Formeln mehr :)
2. ich bräuchte noch einen Code, der mir alle erstellten Mappen (außer die Mappe "Steuerung", "Liste", "Muster") als PDF in einen Ordner legen (per Eingabefenster einen Ordner suchen/anlegen)
Das wäre noch ein Traum :)
Aber ich bin dir schon jetzt sehr dankbar, weil du mir (mal wieder) super geholfen hast.

Sub Mach()
Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet, WS4 As Worksheet
Dim iZeile As Long, letzteZeile As Long
Dim Name As Long
Set WS1 = Worksheets("Liste")
Set WS2 = Worksheets("Muster")
Set WS3 = Worksheets("Steuerung")
Application.ScreenUpdating = False
Call TBloeschen(WS1, WS2, WS3)
letzteZeile = WS1.Cells(Rows.Count, 1).End(xlUp).Row
For iZeile = 2 To letzteZeile
If WorksheetFunction.CountIf(WS1.Range("A1:A" & iZeile), WS1.Cells(iZeile, 1)) = 1 Then
WS2.Copy After:=Worksheets(Worksheets.Count)
Set WS4 = ActiveSheet
WS4.Name = WS1.Cells(iZeile, 1)
Name = WS4.Name
Range("B5").Value = Name
Call Leerzeilen_ausblenden(WS4)
End If
Next iZeile
WS1.Select
End Sub
Sub nurLoeschen()
Call TBloeschen(Worksheets("Liste"), Worksheets("Muster"), Worksheets("Steuerung"))
End Sub
Private Sub TBloeschen(WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet)
Dim WS As Worksheet
Application.DisplayAlerts = False
For Each WS In ThisWorkbook.Worksheets
If WS.Name  WS1.Name And WS.Name  WS2.Name And WS.Name  WS3.Name Then _
WS.Delete
Next WS
Application.DisplayAlerts = True
End Sub
Private Sub Leerzeilen_ausblenden(WS As Worksheet)
Dim iRow As Long
Dim iCol As Integer
Dim lastRow As Long
lastRow = WS.Cells.Find("*", searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
WS.Rows.EntireRow.Hidden = False
For iRow = lastRow To 7 Step -1
If WS.Cells(iRow, 14) = "" Then
WS.Rows(iRow).EntireRow.Hidden = True
End If
Next
End Sub

Beliebteste Forumthreads (12 Monate)

Erstellung von Mappen mit Namen aus einer Liste

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Erstellung von Mappen mit Namen aus einer Liste

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread