AW: Inhaltsverzeichnis Tabellenblätter automatisc
11.11.2014 10:53:09
Michael
Nochmals Hallo Chris!
Du hast ja von den Profis hier schon viele elegante und tolle Lösungen erhalten - ich zähle mich bei Weitem nicht zu jenen Profis, möchte Dir meine Lösung aber dennoch anbieten, da ich selbst dabei viel gelernt habe. Vielleicht gefällt Dir dieser Ansatz ja auch:
Sub ÜbersichtUmgekehrtChron()
Dim intTabellen As Integer
Dim intZeilenA As Integer
Dim intZeilenB As Integer
Dim intZeilenC As Integer
Dim EndA As Integer
Dim EndB As Integer
Dim EndC As Integer
Application.ScreenUpdating = False
intZeilenA = 5
intZeilenB = 5
intZeilenC = 5
For intTabellen = 2 To ActiveWorkbook.Worksheets.Count
Select Case True
Case Worksheets(intTabellen).Name Like "Agenda_*"
Worksheets("Übersicht").Cells(intZeilenA, 1).Hyperlinks.Add _
Anchor:=Worksheets("Übersicht").Cells(intZeilenA, 1), Address:="", SubAddress:= _
_
"'" & Worksheets(intTabellen).Name & "'!A1", _
ScreenTip:="Klicken Sie um zur Tabelle zu gelangen", _
TextToDisplay:=Worksheets(intTabellen).Name
Worksheets("Übersicht").Cells(intZeilenA, 1).Value = Right(Worksheets( _
intTabellen).Name, 10)
intZeilenA = intZeilenA + 1
Case Worksheets(intTabellen).Name Like "MoM*"
Worksheets("Übersicht").Cells(intZeilenB, 2).Hyperlinks.Add _
Anchor:=Worksheets("Übersicht").Cells(intZeilenB, 2), Address:="", SubAddress:= _
_
"'" & Worksheets(intTabellen).Name & "'!A1", _
ScreenTip:="Klicken Sie um zur Tabelle zu gelangen", _
TextToDisplay:=Worksheets(intTabellen).Name
Worksheets("Übersicht").Cells(intZeilenB, 2).Value = Right(Worksheets( _
intTabellen).Name, 10)
intZeilenB = intZeilenB + 1
Case Worksheets(intTabellen).Name Like "AcRep*"
Worksheets("Übersicht").Cells(intZeilenC, 3).Hyperlinks.Add _
Anchor:=Worksheets("Übersicht").Cells(intZeilenC, 3), Address:="", SubAddress:= _
_
"'" & Worksheets(intTabellen).Name & "'!A1", _
ScreenTip:="Klicken Sie um zur Tabelle zu gelangen", _
TextToDisplay:=Worksheets(intTabellen).Name
Worksheets("Übersicht").Cells(intZeilenC, 3).Value = Right(Worksheets( _
intTabellen).Name, 10)
intZeilenC = intZeilenC + 1
End Select
Next intTabellen
EndA = Worksheets("Übersicht").Cells(5, 1).End(xlDown).Row
EndB = Worksheets("Übersicht").Cells(5, 2).End(xlDown).Row
EndC = Worksheets("Übersicht").Cells(5, 3).End(xlDown).Row
ActiveWorkbook.Worksheets("Übersicht").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Übersicht").Sort.SortFields.Add Key:=Range("A5"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Übersicht").Sort
.SetRange Range(Cells(5, 1), Cells(EndA, 1))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Übersicht").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Übersicht").Sort.SortFields.Add Key:=Range("B5"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Übersicht").Sort
.SetRange Range(Cells(5, 2), Cells(EndB, 2))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Übersicht").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Übersicht").Sort.SortFields.Add Key:=Range("C5"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Übersicht").Sort
.SetRange Range(Cells(5, 3), Cells(EndC, 3))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For intZeilenA = 5 To EndA
Worksheets("Übersicht").Cells(intZeilenA, 1).Value = "Agenda " & Worksheets("Übersicht") _
.Cells(intZeilenA, 1).Value
Next intZeilenA
For intZeilenB = 5 To EndB
Worksheets("Übersicht").Cells(intZeilenB, 2).Value = "MoM " & Worksheets("Übersicht"). _
Cells(intZeilenB, 2).Value
Next intZeilenB
For intZeilenC = 5 To EndC
Worksheets("Übersicht").Cells(intZeilenC, 3).Value = "AcRep " & Worksheets("Übersicht"). _
Cells(intZeilenC, 3).Value
Next intZeilenC
Application.ScreenUpdating = True
End Sub
Beste Grüße
Michael