Neue Tabellenblätter anlegen

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

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

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread