Makro für automatische Hyperlinkverknüofung gesucht

[BassMoBill]

Ich hab eine ToDoliste (Tabellebblatt Jahr 2012) mit 6 Spalten:
Nr. Projektbezeichnung Startdatum Bearbeiter Status Priorität


Zu jeder Nummer will ich ein Tabellenblatt erstellen dass die Nummer des jeweiligen Projektes und die gleiche Kopfzeile hat.
DAS habe ich schon geschafft mit folgendem Makro:
Sub Tabellenblatt_anlegen()

' 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

Folgende Probleme habe ich noch zu lösen und komme nicht weiter:

1. Vom ersten Tabellenblatt (Tabellenblatt 2012) soll die letzte aktive Nummer der Liste (Spalte Nr.) einen Hyperlink zum gerade generierten neuen Tabellenblatt bekommen.

2. Bei einem neu generierten Tabellenblatt soll neben der Kopfzeile, die letzte Zeile der To-Do Liste (Tabellenblatt 2012) als Verknüpfung in Zeile 4 dargestellt werden.

Ein Beispielfile wie es fertig aussehen soll habe ich angehängt.



Ich bekomme einfach die Logik nicht hin, wie ich dem Excel sage wo das Ende der Liste ist und dass er genau das ins gerade gernerierte Tabellenblatt kopieren bzw. verknüpfen soll.

 

[Zvoni]

Sorry, aber deine Problematik habe ich jetzt überhaupt nicht verstanden. Speziell dieses "letzte Aktive Nr." und "letzte Zeile"

 

[BassMoBill]

Okay nochmal langsamer:

Ich habe eine Tabelle auf einem Tabellenblatt (2012) mit verschiedenen Spalten.
Die erste Spalte soll Zeile für Zeile eine neue Nummer erhalten. Dass ist vorbereitet.

Nr. Projektbezeichnung Startdatum Bearbeiter Status Priorität

1 ABC 1.1.2012
2 ghf 2.5.2012
...

Jede Zeile steht für ein Projekt. Wenn ein neues Projekt bzw. eine neue Zeile mit "Leben" gefüllt wird möchte ich mit einem Makro folgende Funktionen darstellen.

1. Generiere ein Tabellenblatt mit der Nummer der letzten Zeile (=letzte Projektnummer)
2. Kopiere die Kopfzeile vom Tabellenblatt "2012" auf das gerade erstellte Tabellenblatt
3. Verknüpfe die nun letzte Zeile der Tabelle vom Tabellenblatt "2012", Spalte A-F auf das gerade erstellte neue Tabellenblatt in Zeile 5, Spalte A-F
4. Generiere ein Hyperlink auf die letzte Projektnummer (Spalte A) zum gerade erstellten Tabellenblatt


Damit ist im Tabellenblatt "2012" immer der Titel der jeweiligen Projekte sichtbar und der Unterbau kann auf "Klick" der Projektnummer angesehen werden, da dann auf das Tabellenblatt mit der jeweiligen Projektnummer verknüpft wird.
Jedes Mal wenn eine neue Zeile im Tabellenblatt 2012 ausgefüllt wird soll im Anschluss dann eben das passende Projektblatt für den Unterbau generiert werden und die dazu passende Verknüpfung in Spalte "Nr" eingefügt werden.



War die Erklärung besser? Funktion 1+2 habe ich schon darstellen können (war auch die einfachere Aufgabe).

 

[Yaslaw]

Ist nicht so schwer wie es klingt

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

Dabei habe ich auf die 3 folgenden Funktionen zurückgegriffen

'/**
' * 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

 

[Zvoni]

Yaslaw,

ich sehe da aber ein Problem mit deinem xlsGetLastRow: Nach seinem Screenshot zu urteilen tut er ja Spalte A quasi mit "Dummies" vorfüllen (1, 2, 3, 4, 5 usw.)

In seinem Screenshot hat er ja Spalte A mit 1 bis 5 vorgefüllt, wobei aber nur bei 1-3 etwas in Spalte B, C usw. was steht.

Wenn ich deinen Code richtig verstehe, würde er für 4 und 5 ein "leeres" Projekt erzeugen, welches zudem noch keinen Titel hat geschweige denn einen Hyperlink.

Wäre es in diesem Fall nicht besser auf eine [LEER]-Prüfung in Spalte B zu gehen?

Er hat ja anscheinend einen Button "Neues Projekt anlegen". Meiner Meinung müsste der Algorithmus ungefähr in die Richtung gehen:

Bei Click auf "Neues Projekt anlegen":
1) Gehe Spalte B von oben nach unten
2) Prüfe zu jeder Zeile, in der Spalte B nicht leer ist, ob es bereits ein Tabellenblatt mit Namen gleich Wert in Spalte A gibt (Damit er nicht versucht, ein Tabellenblatt zweimal anzulegen)
3) Wenn Spalte B nicht leer und kein Tabellenblatt mit Namen gleich Wert aus Spalte A, dann füge neues Tabellenblatt an blablablabla

Oder hab ich jetzt nen Denkfehler?

 

[Yaslaw]

Ein bisschen was anpassen sollte ja noch drin sein. Ist ja dokumentiert *g*.
Ich habe die Grafiken nicht wirklich angeschaut, da sie so breit sind, dass ich an meinem Bildschirm eine Lupe nehmen muss um etwas zu erkennen. Es ist also eine reine Umsetzung Beschreibung aus Post #3.

 

[BassMoBill]

Danke Jungs,

ich check das mal. Krass wie schnell und umfangreich ihr mir helfen konntet. Ich nehm mal die Codes und spiel ein bisschen rum. Vielen Vielen Dank schon mal.

Flo