Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1680to1684
1680to1684
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Neue Tabellenblätter anlegen

Forumthread: Neue Tabellenblätter anlegen

Neue Tabellenblätter anlegen
27.03.2019 13:13:10
Robert
Hallo,
nachdem mir das letzte mal so gut geholfen wurde, hätte ich das nächste Problem:
Ich habe eine XLSM-Mappe mit einem Blatt ("Master") für die Zeiterfassung von Mitarbeitern.
https://www.herber.de/bbs/user/128703.xlsm
Funktioniert soweit super.
Ich kopiere den Master als neues Tabellenblatt, und benenne es nach dem Mitarbeiter. Die Mappe enthält eine Tabelle aller Mitarbeiter als separates Blatt. Bei mehr als 40 Mitarbeitern ist das ganz schön anstrengend. Ich suche einen VBA-Code, der den "Master" kopiert und dann den passenden Namen gemäß der Namensliste vergibt. Am besten noch mit der passenden Verlinkung, damit man das Zeiterfassungsblatt direkt aus der Namensliste heraus anklicken kann.
MfG,
Robert
Anzeige

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

Betreff
Datum
Anwender
Anzeige
AW: Neue Tabellenblätter anlegen
27.03.2019 13:41:39
Werner
Hallo Robert,
teste: 
Sub KopieMaster()
Dim raFund As Range, boVorhanden As Boolean
Application.ScreenUpdating = False
With Worksheets("Mitarbeiter")
Set raFund = .Columns(1).Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, _
searchdirection:=xlPrevious)
If Not raFund Is Nothing Then
For i = 3 To raFund.Row
boVorhanden = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = .Cells(i, 1) Then
boVorhanden = True
Exit For
End If
Next ws
If Not boVorhanden Then
Worksheets("Master").Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = .Cells(i, 1)
.Cells(i, 1).Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", SubAddress:="'"  _
_
& ActiveSheet.Name & "'!A1", TextToDisplay:=ActiveSheet.Name
End If
Next i
End If
End With
Set raFund = Nothing
End Sub
Gruß Werner
Anzeige
AW: Neue Tabellenblätter anlegen
27.03.2019 13:55:23
Robert
Wow!
Wie macht ihr das so schnell?
Ich mache gerade erste Schritte mit dem Makro-Recorder... :-(
Vielen Dank für das Script. Das ist zu 99% das, was ich suche!
Ich habe es als Modul in den Editor kopiert und es läuft.
Das letzte i-Tüpfelchen wäre, wenn der Name in Feld F1 auf jedem kopierten Blatt gleich richtig ausgewählt wäre (derzeit steht auf jedem kopierten Blatt der Name, der auf der Master-Tabelle ausgewählt ist). Dann könnte ich mir die Dropdown-Liste gleich sparen....
Ein riesen Dankeschön an Werner! :-))
Robert
Anzeige
AW: Neue Tabellenblätter anlegen
27.03.2019 14:02:02
Werner
Hallo Robert,
dann so: 
Sub KopieMaster()
Dim raFund As Range, boVorhanden As Boolean
Application.ScreenUpdating = False
With Worksheets("Mitarbeiter")
Set raFund = .Columns(1).Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, _
searchdirection:=xlPrevious)
If Not raFund Is Nothing Then
For i = 3 To raFund.Row
boVorhanden = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = .Cells(i, 1) Then
boVorhanden = True
Exit For
End If
Next ws
If Not boVorhanden Then
Worksheets("Master").Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = .Cells(i, 1)
.Cells(i, 1).Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", _
SubAddress:="'" & ActiveSheet.Name & "'!A1", _
TextToDisplay:=ActiveSheet.Name
ActiveSheet.Range("F1") = .Cells(i, 1)
End If
Next i
End If
End With
Set raFund = Nothing
End Sub
Gruß Werner
Anzeige
oder...
27.03.2019 14:03:34
Werner
Hallo Robert,
...die Variante von Uwe, die legt automatisch ein entsprechendes Blatt an, sobald du in der Tabelle Mitarbeiter einen neuen Mitarbeiter erfasst.
Gruß Werner
AW: oder...
27.03.2019 14:29:09
Robert
Ich bin Mega begeistert, wie gut einem hier geholfen wird!
Zweites i-Tüpfelchen:
Das Skript erzeugt neue Tabellenblätter gemäß Mitarbeiterliste, benennt sie richtig und wählt jetzt auch in F1 den richtigen Namen aus. Beim zweiten Ausführen des Skript passiert nichts, da geprüft wird, ob ein entsprechendes Blatt bereits vorhanden ist. Bis hierher alles richtig.
Füge ich aber jetzt einen Mitarbeiter in meiner Liste hinzu und führe das Skript erneut aus, wird das Tabellenblatt des neuen Mitarbeiters ganz hinten angefügt und nicht in alphabetischer Sortierung.
Das geht nicht zufälligerweise noch anders?
Anzeige
AW: oder...
27.03.2019 15:19:38
UweD
Hallo nochmal
dann müssen die Tabellenblätter einzeln sortiert werden.
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KName As String, NName As String, Arr, x As Integer, y As Integer
    If Not Intersect(Range("A:A"), Target) Is Nothing Then
        If Target.Row > 2 Then
            KName = WorksheetFunction.Proper(Target.Value) 'je ester Buchstabe groß, Wichtig für Blattsortiereung 
            
            'Nachname ermitteln 
            Arr = Split(KName, ",")
            NName = Arr(0)
            
            'prüfen ob Blatt schon existiert 
            If IsError(Evaluate(NName & "!A1")) Then
                
                'Wenn noch nicht da, dann Master ans Ende kopieren 
                Sheets("Master").Copy after:=Sheets(Sheets.Count)
                
                With ActiveSheet
                    'Blatt benennen 
                    .Name = NName
                    
                    'Name in F1 
                    .Range("F1") = Target.Value
                End With
                    
                'Link zum Blatt anlegen 
                With Sheets("Mitarbeiter")
                    .Hyperlinks.Add Anchor:=Target.Cells, Address:="", _
                        SubAddress:=NName & "!A1", TextToDisplay:=KName
                    
                    'Tabelle sortieren 
                    With .ListObjects("tblMitarbeiter").Sort
                        .SortFields.Clear
                        .SortFields.Add2 Key:=Range("tblMitarbeiter[[#All],[Mitarbeiter]]"), _
                            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        .Header = xlYes
                        .MatchCase = False
                        .Orientation = xlTopToBottom
                        .SortMethod = xlPinYin
                        .Apply
                    End With
                
                    'Blätter sortieren ab Nr. 4 
                    For x = 4 To ActiveWorkbook.Sheets.Count
                        For y = x To ActiveWorkbook.Sheets.Count
                            If Sheets(y).Name < Sheets(x).Name Then
                                Sheets(y).Move Before:=Sheets(x)
                            End If
                        Next y
                    Next x
                
                'Blatt Mitarbeiter auswählen 
                .Activate
                
                End With

            End If
            
        End If
    End If

End Sub

LG UweD
Anzeige
AW: Neue Tabellenblätter anlegen
27.03.2019 13:57:56
UweD
Hallo
- Rechtsclick auf den Tabellenblattreiter "Mitarbeiter"
- Code anzeigen
- Reinkopieren
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NName As String, Arr
    If Not Intersect(Range("A:A"), Target) Is Nothing Then
        If Target.Row > 2 Then
            Arr = Split(Target.Value, ",")
            
            'Nachname ermitteln 
            NName = Arr(0)
            
            'prüfen ob Blatt schon existiert 
            If IsError(Evaluate(NName & "!A1")) Then
                
                'Wenn noch nicht da, dann Master ans Ende kopieren 
                Sheets("Master").Copy after:=Sheets(Sheets.Count)
                
                With ActiveSheet
                    'Blatt benennen 
                    .Name = NName
                    
                    'Name in F1 
                    .Range("F1") = Target.Value
                    
                    'Link zum Blatt anlegen 
                    Sheets("Mitarbeiter").Hyperlinks.Add Anchor:=Target.Cells, Address:="", _
                        SubAddress:=NName & "!A1", TextToDisplay:=Target.Value

                End With
            End If
            
        End If
    End If

End Sub
LG UweD
Anzeige
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige