AW: Hyperlink auf neues Tabellenblatt
22.07.2015 15:28:45
Klexy
Das ist nicht schwer, aber braucht einige Voraussetzungen und hat einige Einschränkungen.
1. Ein Tabellenblatt darf als Name nur 31 Zeichen haben. "Evaluation Competency " sind schon 22 Zeichen. Bleiben also noch max. 9 Zeichen, wodurch "Soft Faktoren" keinen Platz mehr hat (abgesehen davon, dass man Soft-Faktoren mit Bindestrich schreibt!)
2. Um bei den neuen Namen flexibel zu sein, solltest du die Basisbezeichnungen der 3 Blätter entsprechend minimieren. Ich gehe davon aus, dass die Leute, die damit umgehen, das nicht in jedem Registerreiter im Volltext lesen müssen.
Also: "Rank", Comp" und "Risk" - kurz und deutlich.
Das gibt dir größere Freiheit bei der Wahl des neuen Namens und besetzt nicht mit Nullinformation große Teile der Registerreiter, wodurch du dann weniger seitlich scrollen musst.
3. Jetzt kannst du deine Vervielfältigungsmakros deutlich kürzen.
Und ins "MehrereMakros" noch das Makro mit der Linkerzeugung hängen.
Ich hab die Einzelmakros auch umbenannt, damit die Benennung einheitlich ist.
Die Definition von "NeuerName" und "Quelle" erfolgt außerhalb der makros, damit sie für alle Makros gleichermaßen gilt und der Wert Makroübergreifend vergeben und abgerufen werden kann.
Man könnte natürlich auch eine Prüflogik einbauen, die einem sagt, wenn der Tabellenname zu lang ist. Aber das ist Luxus.
Dim NeuerName As String
Dim Quelle As String
Sub RankingKopieren()
Dim Blatt As String
Blatt = "Rank"
Dim i As Integer
i = Sheets.Count
ActiveWorkbook.Sheets(Blatt & " " & Quelle).Copy after:=ActiveWorkbook.Sheets(Worksheets. _
Count)
ActiveSheet.Name = Blatt & " " & NeuerName
End Sub
Sub CompetencyKopieren()
Dim Blatt As String
Blatt = "Comp"
Dim i As Integer
i = Sheets.Count
ActiveWorkbook.Sheets(Blatt & " " & Quelle).Copy after:=ActiveWorkbook.Sheets(Worksheets. _
Count)
ActiveSheet.Name = Blatt & " " & NeuerName
End Sub
Sub RiskKopieren()
Dim Blatt As String
Blatt = "Risk"
Dim i As Integer
i = Sheets.Count
ActiveWorkbook.Sheets(Blatt & " " & Quelle).Copy after:=ActiveWorkbook.Sheets(Worksheets. _
Count)
ActiveSheet.Name = Blatt & " " & NeuerName
End Sub
Sub MehrereMakros()
Dim nZeile As Integer
NeuerName = InputBox("Bitte gib den neuen Namen ein!")
Quelle = "Projektgetrieben"
Application.ScreenUpdating = False
Application.Run "RankingKopieren"
Application.Run "CompetencyKopieren"
Application.Run "RiskKopieren"
Application.Run "LinksSetzen"
Application.ScreenUpdating = True
End Sub
Sub LinksSetzen()
Sheets("Übersicht").Select
nZeile = Range("B2").End(xlDown).Row + 1
Cells(nZeile, 2).Select
Selection = NeuerName
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'Rank " & NeuerName _
& "'!A1", TextToDisplay:=NeuerName
With Selection.Font
.Name = "Calibri"
.Size = 12
.Underline = xlUnderlineStyleSingle
.Color = RGB(0, 0, 255)
.Bold = True
End With
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
Cells(nZeile, 3).Select
Selection = NeuerName
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'Comp " & NeuerName _
& "'!A1", TextToDisplay:=NeuerName
With Selection.Font
.Name = "Calibri"
.Size = 12
.Underline = xlUnderlineStyleSingle
.Color = RGB(0, 0, 255)
.Bold = True
End With
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
Cells(nZeile, 4).Select
Selection = NeuerName
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'Risk " & NeuerName _
& "'!A1", TextToDisplay:=NeuerName
With Selection.Font
.Name = "Calibri"
.Size = 12
.Underline = xlUnderlineStyleSingle
.Color = RGB(0, 0, 255)
.Bold = True
End With
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
End Sub