AW: Mit deklarationen weiterarbeiten.
27.08.2019 17:08:11
Werner
Hallo,
teste mal:
Sub ERSTELLEN()
Dim i As Long, j As Long, z As Long, Arr() As Long, vz As String
Dim NName As String, Mmax As Long, Istda As Boolean, TBM As Long, TBN As Long
Dim Neu As Long, ZB As Boolean, Blatt As String, VNam As String, NNam As String
Dim filesystem As Object, strPfad As String, lZ As Long, intI As Long, intJ As Long
Sheets("MASTER").Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowFiltering:=True, AllowUsingPivotTables:=True
Set TBM = Sheets("Master") 'die MasterTab
For i = 1 To Sheets.Count
NName = Sheets(i).Name
If IsNumeric(NName) Then
ReDim Preserve Arr(z)
Arr(z) = NName
z = z + 1
ZB = True
End If
Next
If ZB Then
Mmax = Application.WorksheetFunction.Max(Arr)
For i = 1 To Mmax
For j = LBound(Arr) To UBound(Arr)
If Arr(j) = i Then
Istda = True
Exit For
Else
Istda = False
End If
Next j
If Istda = False Then
Neu = i
GoTo Weiter
End If
Next i
End If
Weiter:
With TBM
.Visible = True
.Copy after:=Sheets(Sheets.Count)
.Visible = False
End With
With ActiveSheet
vz = "00"
If Mmax = i - 1 And Mmax >= 9 And Mmax Mmax Then
If i >= 10 And i 0, vz & Neu, vz & Mmax + 1)
.Unprotect
Blatt = .Name
.Range("A2") = Blatt
''''Vorname ermitteln
VNam = InputBox("Vorname eingeben:", "Vorname")
If VNam = "" Then
MsgBox "Es muss ein Vorname angegeben werden."
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Exit Sub
End If
''''Nachname ermitteln
NNam = InputBox("Nachname eingeben:", "Nachname")
If NNam = "" Then
MsgBox "Es muss ein Nachname angegeben werden."
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Exit Sub
End If
.Range("C2") = NNam & ", " & VNam
'ORDNER FÜR NEUE TABELLE'
strPfad = ThisWorkbook.Path
Set filesystem = CreateObject("Scripting.FileSystemObject")
filesystem.CopyFolder strPfad & "\001 Aktive Mitarbeiter\000 MASTER", _
strPfad & "\001_Aktive Mitarbeiter\" & Blatt
Set filesystem = Nothing
'HYPERLINKS FÜR NEUE TABELLE'
.Range("L5").Hyperlinks.Add Anchor:=.Range("L5"), Address:= _
"001 Aktive Mitarbeiter\" & Blatt & "\" & "001%20Arbeitsanweisungen", _
TextToDisplay:="Arbeitsanweisungen"
.Range("L6").Hyperlinks.Add Anchor:=.Range("L6"), Address:= _
"001 Aktive Mitarbeiter\" & Blatt & "\" & "002%20Krank", _
TextToDisplay:="Krank"
.Range("L7").Hyperlinks.Add Anchor:=.Range("L7"), Address:= _
"001 Aktive Mitarbeiter\" & Blatt & "\" & "003%20Urlaub", _
TextToDisplay:="Urlaub"
.Range("L8").Hyperlinks.Add Anchor:=.Range("L8"), Address:= _
"001 Aktive Mitarbeiter\" & Blatt & "\" & "004%20Kleidung_Werkzeug", _
TextToDisplay:="Kleidung / Werkzeug"
.Range("L9").Hyperlinks.Add Anchor:=.Range("L9"), Address:= _
"001 Aktive Mitarbeiter\" & Blatt & "\" & "005%20sonstiges", _
TextToDisplay:="SONSTIGES"
.Range("A2").Hyperlinks.Add Anchor:=.Range("A2"), Address:= _
"001 Aktive Mitarbeiter\" & Blatt, _
TextToDisplay:=Blatt
.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowFiltering:=True, AllowUsingPivotTables:=True
End With
'STARTSEITE BEFÜLLEN UND SORTIEREN'
With Worksheets("Startseite")
lZ = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
If .Cells(2, 2).Value = "" Then lZ = 2
.Cells(lZ, 2).Value = Blatt
.Cells(lZ, 2).Hyperlinks.Add Anchor:=.Cells(lZ, 2), Address:="", SubAddress:= _
Blatt & "!A1", TextToDisplay:=Blatt
.Cells(lZ, 3).Value = NNam
.Cells(lZ, 4).Value = VNam
End With
'LISTENSEITE BEFÜLLEN UND SORTIEREN'
With Worksheets("LISTE")
lZ = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
If .Cells(2, 1).Value = "" Then lZ = 2
.Cells(lZ, 1).Value = Blatt
.Cells(lZ, 1).Hyperlinks.Add Anchor:=.Cells(lZ, 1), Address:="", SubAddress:= _
Blatt & "!A1", TextToDisplay:=Blatt
.Cells(lZ, 2).Value = NNam
.Cells(lZ, 3).Value = VNam
.Cells(lZ, 4).Value = WorksheetFunction.VLookup _
(1, Worksheets(Blatt).Range("A4:O24 "), 2, False)
.Range("B1") = WorksheetFunction.VLookup _
(.Range("A1"), Worksheets("Tabelle2").Range("A1:B4"), 2, False)
End With
'PERSONALMAPPEN NUMMERISCH SORTIEREN'
For intI = 1 To Sheets.Count
For intJ = 1 To Sheets.Count - 1
If UCase(Sheets(intJ).Name) > UCase(Sheets(intJ + 1).Name) Then
Sheets(intJ).Move after:=Sheets(intJ + 1)
End If
Next
Next
''''ARBEITSLISTEN NACH VORNE SORTIEREN
With Worksheets("INAKTIVE")
.Move Before:=Sheets(1)
End With
With Worksheets("LISTE")
.Move Before:=Sheets(1)
End With
With Worksheets("Startseite")
.Move Before:=Sheets(1)
End With
''''MASTERFOLIE SPERREN
Sheets("MASTER").Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowFiltering:=True, AllowUsingPivotTables:=True
End Sub
Gruß Werner