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
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.
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
habe es glaub ich herausgefunden....so sollte es gehen
If ThisWorkbook.Sheets("Liste").Cells(i, 2).Value = Worksheets("Liste").Cells(1, 2).Value
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