Makro für automatische Hyperlinkverknüofung gesucht

' Kopfzeilekopieren Makro
'

'
    Range("A1:F4").Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Range("A1").Select
    ActiveSheet.Paste


'
' Tabellenblatt_anlegen Makro
'

'
    ActiveSheet.Select
    ActiveSheet.Name = Sheets.Count - 1
    Columns("B:B").ColumnWidth = 54.43
'

 '
' Makro10 Makro
'

'
    Range("A1:F3").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "'2012'!A1", TextToDisplay:="Projekte und Aufgaben - Montageplanung Werk Ulm"

    With Selection.Font
        .Name = "Calibri"
        .Size = 18
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleSingle
        .ThemeColor = xlThemeColorHyperlink
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    
    
End Sub

Sub test()
    Dim wsOverview  As Worksheet
    Dim wsProject   As Worksheet
    Dim lastRowNr   As Long
    Dim lastColNr   As Integer
    Dim projectNr   As Variant
    Dim colNr       As Integer
    
    'Das Übersichtssheet laden
    Set wsOverview = ActiveWorkbook.Worksheets("2012")
    
    'Letze Spalte und letzte Zeile ermitteln (die Funktionen dazu findest du weiter unten)
    lastRowNr = xlsGetLastRow(wsOverview)
    lastColNr = xlsGetLastCol(wsOverview)
    
    'Projektnummer auslesen und ein neues Sheet anlegen
    projectNr = wsOverview.Cells(lastRowNr, 1)
    Set wsProject = ActiveWorkbook.Worksheets.Add(after:=wsOverview)
    wsProject.Name = "Projekt " & projectNr
    
    'Titelbereich aus der Übersicht kopieren
    Call wsOverview.Range("1:1").Copy(wsProject.Range("1:1"))
    
    'Verlinkungen der Daten der Übersicht in das Projektsheet verlinken
    For colNr = 1 To lastColNr
        'Link erstellen (die Funktion um die Spaltennummer in Buchstaben zu wandeln findest du weiter unten)
        wsProject.Cells(2, colNr) = "='" & wsOverview.Name & "'!" & ColumnLetter(colNr) & lastRowNr
    Next colNr
    
    'Hyperlink von dem übersichtssheet auf das Projektsheet erstellen
    Call wsOverview.Hyperlinks.Add(wsOverview.Cells(lastRowNr, 1), "", "'" & wsProject.Name & "'!A1", "", CStr(projectNr))
    
    'Obejekte suaber abbauen
    Set wsProject = Nothing
    Set wsOverview = Nothing
End Sub

'/**
' * Die folgenden zusätzlichen Funktionen werden verwendet
' */

'/**
' * Ermittelt die letzte Ziele in einem Excelsheet
' * Das Problem mit Sheet.Cells.SpecialCells(xlCellTypeLastCell).Row ist, dass es trotzdem
' * leere Zeilen haben kann. Darum muss ab da rückwerts getestet werden ob die Zeile leer ist
' * @param  Worksheet       Worksheet dessn letzte befüllte Zeile ermittelt werden soll
' * @return Long            Zeilenzahl der letzten Zeile mit Daten
' */
Public Function xlsGetLastRow(ByRef Sheet As Worksheet) As Long
    Dim r As Variant

    xlsGetLastRow = Sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    For r = xlsGetLastRow To 1 Step -1
        If WorksheetFunction.CountA(Sheet.Rows(r)) = 0 Then
            xlsGetLastRow = r - 1
        Else
            Exit For
        End If
    Next r
End Function

'/**
' * Ermittelt die letzte Spalte in einem Excelsheet
' * Das Problem mit Sheet.Cells.SpecialCells(xlCellTypeLastCell).Column ist, dass es trotzdem
' * leere Spalte haben kann. Darum muss ab da rückwerts getestet werden ob die Spalte leer ist
' * @param  Worksheet       Worksheet dessn letzte befüllte Spalte ermittelt werden soll
' * @return Long            Spaltezahl der letzten Spalte mit Daten
' */
Public Function xlsGetLastCol(ByRef Sheet As Worksheet) As Long
    Dim i As Variant
    xlsGetLastCol = Sheet.Cells.SpecialCells(xlCellTypeLastCell).Column
    For i = xlsGetLastCol To 1 Step -1
        If WorksheetFunction.CountA(Sheet.Columns(i)) = 0 Then
            xlsGetLastCol = i - 1
        Else
            Exit For
        End If
    Next i
End Function

'/**
' * Ermittelt den Buchstabencode einer Spaltnnummer
' * @source http://www.freevbcode.com/ShowCode.asp?ID=4303
' * @param  Integer         Nummer der Spalte
' * @return String          Buchstabenkombination der Spalte
' */
Public Function ColumnLetter(ColumnNumber As Integer) As String
  If ColumnNumber > 26 Then
    ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
                   Chr(((ColumnNumber - 1) Mod 26) + 65)
  Else
    ColumnLetter = Chr(ColumnNumber + 64)
  End If
End Function