Tabellenblätter automatisch erstellen

[Pean]

Hallo Guru's
 
Habe zwei kleine Probleme beim automatischen erstellen von Tabellenblättern.
Was für mich fast unlösbar ist, mangels VBA und Makro Kenntnissen, ist für euch ein müdes Lächeln.
 
Die automatische Erstellung, gemässe einer Liste, funktioniert soweit gut, habe ein funktionierendes Makro dazu gefunden.
Leider wird die Liste stur von Zelle Ax bis Ay abgearbeitet. Ich möchte ein Tabellenblatt jedoch nur erstellen, wenn
 
- der Kunde aus "DE" kommt und
- es nicht schon ein Tabellenblatt mit derselben Kundennummer gibt
 
Kann mir jemand das Makro enrsprechend anpassen?
Wäre mir eine Riesenhilfe, damit ich nicht hunderte von Tabellenblätter periodisch von Hand erstellen muss.


Vielen Dank im Voraus
Grüsse, Pean

[Frogger1986]

Hallo
Eine For Each Schleife ist hier nicht nötig, da du deinen Arbeitsbereich gut definieren kannst. Des weiteren ist hier deine For Each Schleife zu Statisch und müsste bei einer Erweiterung der Tabelle wieder Angepasst werden. Hier lässt sich besser mit einer einfachen For Schleife arbeiten. Ich hab dir deine Tabelle angepasst im Anhang.

---

Im zweiten Anhang ist jetzt auch die Prüfung der Tabellenblätter eingebaut.

[Pean]

Hallo Frogger,

Genial, echt, vielen Dank. Dies erleichtert mir die Arbeit mega.

Was müsste ich ändern, wenn der Wert in der Tabelle B1 - Bn (DE, BEL, NED, etc.) mit der Zelle B1 verglichen Wert wird, damit ich variable bin bezüglich dieser Abfrage und den Wert "DE" nicht direkt im Makro habe.

Grüsse
Pean




Sub Tabellenblääter_erstellen()
    Dim i As Integer
    Dim Last As Long
    Dim sheet As Worksheet
   
    Last = ThisWorkbook.Sheets("Liste").Cells(Rows.Count, 1).End(xlUp).Row 'Letzte benutzte Zeile im Bereich
   
    On Error GoTo ErrExit
   
    GetMoreSpeed
   
    For i = 4 To Last
        If ThisWorkbook.Sheets("Liste").Cells(i, 2).Value = "DE" Then
            SH = False
            For Each sheet In ThisWorkbook.Sheets
                If sheet.Name = ThisWorkbook.Sheets("Liste").Cells(i, 1).Value Then
                    SH = True
                    Exit For
                End If
            Next
            If SH = False Then
                ThisWorkbook.Sheets("Muster").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                With ThisWorkbook.Worksheets(Sheets.Count)
                    .Name = ThisWorkbook.Sheets("Liste").Cells(i, 1).Value
                    .Cells(2, 1) = ThisWorkbook.Sheets("Liste").Cells(i, 1).Value
                    .Cells(1, 2).Value = ThisWorkbook.Sheets("Liste").Cells(i, 2).Value
                End With
            End If
        End If
    Next
   
ErrExit:
    GetMoreSpeed 0
End Sub

[Pean]

habe es glaub ich herausgefunden....so sollte es gehen

If ThisWorkbook.Sheets("Liste").Cells(i, 2).Value = Worksheets("Liste").Cells(1, 2).Value

[Pean]

Hallo Frogger,

Brauche nochmals deine Profikenntnisse.

Neben dem Erstellen der Tabellenblätter, will ich gleichzeitig die Kundennummer in eine Liste eintragen und mit den Tabellenblätter verlinken.
Das mit dem Eintragen in die Liste würde soweit funktionieren, aber das ganze wurde verdammt langsam. Ich nehme an ich habe es viel zu kompliziert umgesetzt.
Das mit dem Hyperlink habe ich nicht hingekriegt.
Kannst du bitte die roten Einträge unten nochmals kurz anschauen anschauen und optimieren.

Vielen Dank
Grüsse Pean


Sub Kundenliste()
'
Dim i As Integer
    Dim Last As Long
    Dim sheet As Worksheet
    Dim Kundennummer As String
   
    Last = ThisWorkbook.Sheets("Liste").Cells(Rows.Count, 1).End(xlUp).Row 'Letzte benutzte Zeile im Bereich
   
    On Error GoTo ErrExit
   
    GetMoreSpeed
   
    For i = 4 To Last
        If ThisWorkbook.Sheets("Liste").Cells(i, 2).Value = Worksheets("Liste").Cells(1, 2).Value And ThisWorkbook.Sheets("Liste").Cells(i, 3).Value > 0 Or ThisWorkbook.Sheets("Liste").Cells(i, 4).Value > 0 Then
                    SH = False
            For Each sheet In ThisWorkbook.Sheets
                If sheet.Name = ThisWorkbook.Sheets("Liste").Cells(i, 1).Value Then
                    SH = True
                    Exit For
                End If
            Next
            If SH = False Then
              ThisWorkbook.Sheets("Muster").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                      With ThisWorkbook.Worksheets(Sheets.Count)
                    .Name = ThisWorkbook.Sheets("Liste").Cells(i, 1).Value
                    .Cells(2, 1) = ThisWorkbook.Sheets("Liste").Cells(i, 1).Value
                    .Cells(1, 2).Value = ThisWorkbook.Sheets("Liste").Cells(i, 2).Value
              Sheets("Kundenliste").Select
              Range("A8").Select
              Selection.End(xlDown).Select
              ActiveCell.Cells(2, 1).Select
              ActiveCell.Value = ThisWorkbook.Sheets("Liste").Cells(i, 1).Value
              ActiveCell.Value = Kundennummer
              ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & Kundennummer & "'!A1", TextToDisplay:=Kundennummer '
                End With
            End If
        End If
    Next