VBA Code erweitern
21.04.2016 17:11:18
Stefan
Ich möchte gerne meinen VBA-Code erweitern und bräuchte eure Hilfe dafür.
Der jetzige Code ist so aufgebaut, er kopiert mir mein Tabellenblatt das "Vorlage" heißt, aufgrund von Namen die in dem Tabellenblatt "Mitarbeiterliste" in dem Bereich B4:C35 stehen (in B4 steht der Nachname und in C4 der Vorname usw). Und kopiert/benennt die Vorlage automatisch nach den Nachnamen des Mitarbeiters, und schreibt auch in die Zelle B2 den Namen.
Jetzt kommt ein neues Tabellenblatt dazu das "Gesamt" heißt. In diesen hätte ich gern, dass in dem Bereich B4:B35 wieder der Name des einzelnen Mitarbeiters steht. Direkt neben dem Namen des Mitarbeiters also in der Zelle C4 soll die Zelle auf B44 von der Vorlage des Mitarbeiters verweisen. Und in D4 soll er auf Zelle C44 verweisen.
Bsp:
Der Name Mayer Thomas soll in B4 stehen.
In C4 soll der Verweis auf das Tabellenblatt "Mayer" "=Mayer!C44" stehen
In D4 soll der Verweis auf das Tabellenblatt "Mayer" "=Mayer!D44" stehen
Falls es schlecht verständlich ist Bitte schreiben, werde versuchen am Abend noch eine Bsp. Datei hochzuladen.
Vielen Dank schon mal jetzt für die Hilfe!
Hier noch der Code vom jetzigen Makro
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub makeSheets_Test()
Range("B4:C35").Select
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort.SortFields.Add Key:=Range( _
"B4:B35"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Mitarbeiterliste").Sort
.SetRange Range("B4:C35")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("B4").Select
Dim objTemplate As Worksheet
Dim rng As Range, strName As String, strVorname 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("B4:B35")
If Len(Trim$(rng.Text)) Then
strName = Left(Trim(rng.Text), 31)
strVorname = Left(Trim(rng.Offset(0, 1).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") = strVorname & " " & 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