https://www.herber.de/forum/archiv/1448to1452/t1449681.htm
Jetzt möchte ich noch eine kleine Änderung bzw. Anpassung.
Ich habe in der Mitarbeiterliste in den Zellen A1:A29 den Nachnamen des Mitarbeiters stehen. Anhand von diesen Namen wird meine Vorlage kopiert und nach dem Mitarbeiter benannt. In die Zelle B2 kopiert sich dann auch nochmal der Name des Mitarbeiters.
Jetzt hätte ich gerne das er mir in die Zelle B2 auch den Vornamen kopiert. Das heißt Mitarbeiter Mayer Thomas, soll das Tabellenblatt Mayer heißen das er kopiert und in B2 Soll Mayer Thomas stehen.
Wie kann man das noch machen, muss ich in der Mitarbeiterliste die Namen in 2 Zellen Schreiben? Oder kann man den in einer Zelle schreiben und er trennt den Namen beim kopieren?
Ich hoffe es kann mir jemand Helfen. Anbei der jetzige Code
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
Option Explicit
Sub makeSheets()
Range("A1:A33").Select
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Add Key:=Range( _
"A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort
.SetRange Range("A1:A32")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Dim objTemplate As Worksheet
Dim rng As Range, strName As String
On Error GoTo ErrExit
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
Set objTemplate = Sheets("Vorlage")
For Each rng In Sheets("Mitarbeiterliste").Range("A1:A29")
If Len(Trim$(rng.Text)) Then
strName = Left(Trim$(rng.Text), 31)
If IsValidSheetName(strName) Then
If Not SheetExist(strName) Then
objTemplate.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Unprotect ""
.Name = strName
.Visible = xlSheetVisible
.Range("B2") = strName
.Protect ""
End With
End If
End If
End If
Next
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'makeSheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - makeSheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Private Function IsValidSheetName(ByVal strName As String) As Boolean
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "^[^\/\\:\*\?\[\]]{1,31}$"
.IgnoreCase = True
IsValidSheetName = .test(strName)
End With
Set objRegExp = Nothing
End Function