AW: Hyperlinks zu allen Tabellen in einer Arbeitsmape
29.09.2006 17:19:11
firmus
Hi Nikolai,
hier 2 Beispiele, beide sind getestet.
Gruss,
Firmus
Sub CounterverzeichnisErstellen()
' Macro1 Macro
' Macro recorded 16.02.2004 by niefi01
Dim i, maxzeil, maxspalt As Integer
ActiveWorkbook.Sheets.Add Before:=Worksheets(1) 'create + überschriften
ActiveSheet.Name = "counter"
Range("A1").Value = "Inhaltsverzeichnis"
Range("c1").Value = "maxzeilen"
Range("d1").Value = "maxspalten"
Range("e1").Value = "Überschriftzeilen"
ActiveCell.Offset(2, 0).Select
For i = 2 To ActiveWorkbook.Sheets.Count 'name + maxzeil + maxspalt setzen
Sheets(i).Activate
Range("a1:ax1").Select
Selection.Copy
maxzeil = ActiveSheet.UsedRange.Rows.Count
maxspalt = ActiveSheet.UsedRange.Columns.Count
Sheets("counter").Select
ActiveCell.Value = i - 1
ActiveCell.Offset(0, 1).Value = Sheets(i).Name
ActiveCell.Offset(0, 2).Value = maxzeil
ActiveCell.Offset(0, 3).Value = maxspalt
ActiveCell.Offset(1, 0).Select
Debug.Print i;
Next i
For i = 2 To ActiveWorkbook.Sheets.Count 'Headerline kopieren
Sheets(i).Activate
Range("a1:ax1").Select
Selection.Copy
Sheets("counter").Select
Range("E" + Trim(Str(i + 1))).Select
ActiveSheet.Paste
Debug.Print i;
Next i
Range("B4").Activate
Do Until ActiveCell.Value = ""
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:= _
ActiveCell.Value & "!A1", TextToDisplay:=ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Sub InhaltsverzeichnisErstellen()
' Macro1 Macro
' Macro recorded 16.02.2004 by niefi01
Dim i As Integer
ActiveWorkbook.Sheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "Inhalt"
Range("A1").Value = "Inhaltsverzeichnis"
ActiveCell.Offset(2, 0).Select
For i = 2 To ActiveWorkbook.Sheets.Count
ActiveCell.Value = i - 1
ActiveCell.Offset(0, 1).Value = Sheets(i).Name
ActiveCell.Offset(1, 0).Select
Next i
Range("B4").Activate
Do Until ActiveCell.Value = ""
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:="", SubAddress:= _
ActiveCell.Value & "!A1", TextToDisplay:=ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Loop
End Sub