Kommentare aus Zellinhalten generieren

[bug99]

dann mach doch einen button der per VBA die Eingabe des "Kommentars" erfasst, im "Kommentar-Tabellenblatt" speichert und den Hyperlink einfügt
evtl könnte auch auf einen bereits vorhanden Kommentar verwiesen werden, oder "Standardkommentare" angeboten werden

[TxbyFmjy]

Das hier kann man bei Bedarf anpassen/ergänzen:

Modul1

Code:

Option Explicit

Sub Schaltfläche1_Klicken()
    UserForm1.Show
End Sub

Userform1

Code:

Option Explicit
Option Compare Text
' ************************************************************************************************
' KONSTANTEN / PARAMETRISIERUNG
' ************************************************************************************************

'Wie viele TextBoxen sind auf der UserForm platziert?
Private Const iCONST_ANZAHL_EINGABEFELDER As Integer = 6

'In welcher Zeile starten die Eingaben?
Private Const lCONST_STARTZEILENNUMMER_DER_TABELLE As Long = 2


' ************************************************************************************************
' EREIGNISROUTINEN DER USERFORM
' ************************************************************************************************

'Neuer Eintrag Schaltfläche Ereignisroutine
Private Sub CommandButton1_Click()
    Call EINTRAG_ANLEGEN 'Aufruf der entsprechenden Verarbeitungsroutine
End Sub

'Löschen Schaltfläche Ereignisroutine
Private Sub CommandButton2_Click()
    Call EINTRAG_LOESCHEN 'Aufruf der entsprechenden Verarbeitungsroutine
End Sub

'Speichern Schaltfläche Ereignisroutine
Private Sub CommandButton3_Click()
    Call EINTRAG_SPEICHERN 'Aufruf der entsprechenden Verarbeitungsroutine
End Sub

'Beenden Schaltfläche Ereignisroutine
Private Sub CommandButton4_Click()
    Unload Me
End Sub

'Klick auf die ListBox Ereignisroutine
Private Sub ListBox1_Click()
    Call EINTRAG_LADEN_UND_ANZEIGEN 'Aufruf der entsprechenden Verarbeitungsroutine
End Sub

'Diese Ereignisroutine wird beim Anzeigen der UserForm ausgeführt
Private Sub UserForm_Activate()
    If ListBox1.ListCount > 0 Then ListBox1.ListIndex = 0 '1. Eintrag selektieren
End Sub

'Startroutine, wird ausgeführt bevor die Eingabemaske angezeigt wird
Private Sub UserForm_Initialize()
    Call LISTE_LADEN_UND_INITIALISIEREN 'Aufruf der entsprechenden Verarbeitungsroutine
End Sub


' ************************************************************************************************
' VERARBEITUNGSROUTINEN
' ************************************************************************************************

'Diese Routine wird aufgerufen um die Liste (ListBox1) zu leeren, einzustellen und neu zu füllen
Private Sub LISTE_LADEN_UND_INITIALISIEREN()
  Dim lZeile As Long
  Dim lZeileMaximum As Long
  Dim i As Integer
 
    'Alle TextBoxen leer machen
    For i = 1 To iCONST_ANZAHL_EINGABEFELDER
        Me.Controls("TextBox" & i) = ""
    Next i

    ListBox1.Clear 'Liste leeren
   
    '4 Spalten einrichten
    'Spalte 1: Zeilennummer des Datensatzes
    'Spalte 2: Name (Spalte A)
    'Spalte 3: Telefon (Spalte B)
    'Spalte 4: E-Mail (Spalte C)
    ListBox1.ColumnCount = 4
   
    'Spaltenbreiten der Liste anpassen (0=ausblenden, nichts=automatisch)
    '"<Breite Spalte 1>;<Breite Spalte 2>;<Breite Spalte 3>;<Breite Spalte 4>"
    ListBox1.ColumnWidths = "0;;;"
    'Feste Breiten: ListBox1.ColumnWidths = "0;100;100;100"
   
    'Um eine Schleife für alle Datensätze zu erhalten benötigen wir die letzte verwendete Zeile
    lZeileMaximum = Tabelle1.UsedRange.Rows.Count 'Benutzer Bereich auslesen
   
    For lZeile = lCONST_STARTZEILENNUMMER_DER_TABELLE To lZeileMaximum
       
        'Nur wenn die Zeile benutzt / nicht leer ist, zeigen wir etwas an:
        If IST_ZEILE_LEER(lZeile) = False Then
           
            'Spalte 1 der Liste mit der Zeilennummer füllen
            ListBox1.AddItem lZeile
           
            'Spalten 2 bis 4 der Liste füllen
            ListBox1.List(ListBox1.ListCount - 1, 1) = CStr(Tabelle1.Cells(lZeile, 1).Text)
            ListBox1.List(ListBox1.ListCount - 1, 2) = CStr(Tabelle1.Cells(lZeile, 2).Text)
            ListBox1.List(ListBox1.ListCount - 1, 3) = CStr(Tabelle1.Cells(lZeile, 3).Text)
       
        End If
       
    Next lZeile
   
End Sub

Private Sub EINTRAG_LADEN_UND_ANZEIGEN()
  Dim lZeile As Long
  Dim i As Integer
   
    'Eingabefelder resetten
    For i = 1 To iCONST_ANZAHL_EINGABEFELDER
        Me.Controls("TextBox" & i) = ""
    Next i
   
    'Nur wenn ein Eintrag selektiert/markiert ist
    If ListBox1.ListIndex >= 0 Then
          
        'Die Zeilennummer des Datensatzes steht in der ersten ausgeblendeten Spalte der Liste,
        'somit können wir direkt zugreifen.
        lZeile = ListBox1.List(ListBox1.ListIndex, 0)
       
        For i = 1 To iCONST_ANZAHL_EINGABEFELDER
            Me.Controls("TextBox" & i) = CStr(Tabelle1.Cells(lZeile, i).Text)
        Next i
           
    End If
   
End Sub

Private Sub EINTRAG_SPEICHERN()
Dim lZeile As Long
Dim i As Integer

    'Wenn kein Datensatz in der ListBox markiert wurde, wird die Routine beendet
    If ListBox1.ListIndex = -1 Then Exit Sub
  
    'Zum Speichern benötigen wir die Zeilennummer des ausgewählten Datensatzes
    lZeile = ListBox1.List(ListBox1.ListIndex, 0)
   
    For i = 1 To iCONST_ANZAHL_EINGABEFELDER
        Tabelle1.Cells(lZeile, i) = Me.Controls("TextBox" & i)
    Next i
   
    'Der Benutzer könnte die angezeigten Werte in der Liste geändert haben,
    'daher aktualisieren wir den ausgewählten Eintrag entsprechend.
    ListBox1.List(ListBox1.ListIndex, 1) = TextBox1
    ListBox1.List(ListBox1.ListIndex, 2) = TextBox2
    ListBox1.List(ListBox1.ListIndex, 3) = TextBox3
   
End Sub

Private Sub EINTRAG_LOESCHEN()
Dim lZeile As Long
 
    'Wenn kein Datensatz in der ListBox markiert wurde, wird die Routine beendet
    If ListBox1.ListIndex = -1 Then Exit Sub
 
    'Beim Löschen fragen wir zuerst den Benutzer noch einmal sicherheitshalber:
    If MsgBox("Sie möchten den markierten Datensatz wirklich löschen?", _
              vbQuestion + vbYesNo, "Sicherheitsabfrage!") = vbYes Then
 
        'Nur wenn er mit <JA> antwortet, löschen wir auch!
 
        'Zum Löschen benötigen wir die Zeilennummer des ausgewählten Datensatzes
        lZeile = ListBox1.List(ListBox1.ListIndex, 0)
       
        'Die ganze Zeile wird nun gelöscht
        Tabelle1.Rows(CStr(lZeile & ":" & lZeile)).Delete
       
        'Und den Eintrag in der Liste müssen wir auch noch entfernen
        ListBox1.RemoveItem ListBox1.ListIndex
   
    End If
   
End Sub

Private Sub EINTRAG_ANLEGEN()
Dim lZeile As Long
   
    lZeile = lCONST_STARTZEILENNUMMER_DER_TABELLE
    'Schleife bis eine leere ungebrauchte Zeile gefunden wird
    Do While IST_ZEILE_LEER(lZeile) = False
        lZeile = lZeile + 1 'Nächste Zeile bearbeiten
    Loop
   
    'Nach Durchlauf dieser Schleife steht lZeile in der ersten leeren Zeile von Tabelle1
    Tabelle1.Cells(lZeile, 1) = CStr("Neuer Eintrag Zeile " & lZeile)
   
    'Und neuen Eintrag in die UserForm eintragen
    ListBox1.AddItem lZeile
    ListBox1.List(ListBox1.ListCount - 1, 1) = CStr("Neuer Eintrag Zeile " & lZeile)
    ListBox1.List(ListBox1.ListCount - 1, 2) = ""
    ListBox1.List(ListBox1.ListCount - 1, 3) = ""
   
    'Den neuen Eintrag markieren mit Hilfe des ListIndex
    ListBox1.ListIndex = ListBox1.ListCount - 1
    'Durch das Click Ereignis der ListBox werden die Daten automatisch geladen
   
    'Und dem Benutzer direkt noch den Cursor in das erste Eingabefeld stellen und alles vorselektieren,
    'so kann der Benutzer direkt loslegen mit der Dateneingabe.
    TextBox1.SetFocus
    TextBox1.SelStart = 0
    TextBox1.SelLength = Len(TextBox1)
   
End Sub


' ************************************************************************************************
' HILFSFUNKTIONEN
' ************************************************************************************************

'Ermittelt, ob eine Zeile in Benutzung ist...
Private Function IST_ZEILE_LEER(ByVal lZeile As Long) As Boolean
  Dim i As Long
  Dim sTemp As String
 
    'Hilfsvariable initialisieren
    sTemp = ""
   
    'Um zu erkennen, ob eine Zeile komplett leer/ungebraucht ist
    'verketten wir einfach alle Spalteninhalte der Zeile miteinander.
    'Ist die zusammengesetzte Zeichenkette aller Spalten leer,
    'ist die Zeile nicht genutzt...
    For i = 1 To iCONST_ANZAHL_EINGABEFELDER
        sTemp = sTemp & Trim(CStr(Tabelle1.Cells(lZeile, i).Text))
    Next i
   
    'Rückgabewert festlegen
    If Trim(sTemp) = "" Then
        'Die Zeile ist leer
        IST_ZEILE_LEER = True
    Else
        'Die Zeile ist mindestens in einer Spalte gefüllt
        IST_ZEILE_LEER = False
    End If
   
End Function

[TxbyFmjy]

Der von mir zitierte Code hat den Nachteil, dass alle Kommentare aus allen Spalten in ein neues Tabellenblatt geschrieben werden.

Um mir das Abschreiben aller bereits vorhandenen Kommentare zu ersparen, ließen sich alle bereits vorhanden Kommentare auf ein neues Blatt kopieren:

Code:

Sub KommentareInNeuesBlattSchreiben()
    Dim wksMitKommentaren As Worksheet  'die Tabelle mit Kommentaren
    Dim wksAusdruck As Worksheet        'die Tabelle zum Ausdrucken
    Dim cmtDieser As Comment            'ein Kommentar
    Dim lngZeile As Long

    Set wksMitKommentaren = ActiveSheet             'Achtung, vorher merken, weil neues Blatt kommt
    Set wksAusdruck = ThisWorkbook.Worksheets.Add() 'macht eine neue Tabelle

    With wksAusdruck
        'Titelzeile schreiben:
        lngZeile = 1
        .Cells(lngZeile, 1).Value = "Adresse"         'vor jeden führenden Punkt wird wksAusdruck gesetzt wegen "With"
        .Cells(lngZeile, 2).Value = "Zellwert"
        .Cells(lngZeile, 3).Value = "Kommentar"
        .Cells(lngZeile, 4).Value = "Transparenz"
        .Rows(lngZeile).Font.Bold = True              'Titelzeile fett machen

        For Each cmtDieser In wksMitKommentaren.Comments    'alle Kommentare durchlaufen und in neuer Tabelle auflisten
            lngZeile = lngZeile + 1
            .Cells(lngZeile, 1).Value = cmtDieser.Parent.AddressLocal
            .Cells(lngZeile, 2).Value = cmtDieser.Parent.Value
            .Cells(lngZeile, 3).Value = cmtDieser.Text
            .Cells(lngZeile, 4).Value = cmtDieser.Shape.Fill.Transparency
        Next
    End With
End Sub

Unter Umständen möchte man lieber alle Kommentare jeweils nur einer einzigen Spalte auf jeweils ein neues Tabellenblatt schreiben:

Code:

Option Explicit
Sub KommentareInNeuesBlattSchreiben_1()
    Dim wksMitKommentaren As Worksheet  'die Tabelle mit Kommentaren
    Dim wksAusdruck As Worksheet        'die Tabelle zum Ausdrucken
    Dim cmtDieser As Comment            'ein Kommentar
    Dim lngZeile As Long
    Dim WatchRange As Range
       
    Set wksMitKommentaren = ActiveSheet             'Achtung, vorher merken, weil neues Blatt kommt
    Set wksAusdruck = ThisWorkbook.Worksheets.Add() 'macht eine neue Tabelle
   
    Set WatchRange = wksMitKommentaren.Range("C:C") 'nacheinander Tabellenspalte ändern

    With wksAusdruck
                    'Titelzeile schreiben:
                    lngZeile = 1
                    .Cells(lngZeile, 1).Value = "Adresse"           'vor jeden führenden Punkt wird wksAusdruck gesetzt wegen "With"
                    .Cells(lngZeile, 2).Value = "Zellwert"
                    .Cells(lngZeile, 3).Value = "Kommentar"
                    .Cells(lngZeile, 4).Value = "Transparenz"
                    .Rows(lngZeile).Font.Bold = True                'Titelzeile fett machen
   
            For Each cmtDieser In wksMitKommentaren.Comments
                If Not Intersect(cmtDieser.Parent, WatchRange) Is Nothing Then
                    lngZeile = lngZeile + 1
                    .Cells(lngZeile, 1).Value = cmtDieser.Parent.AddressLocal
                    .Cells(lngZeile, 2).Value = cmtDieser.Parent.Value
                    .Cells(lngZeile, 3).Value = cmtDieser.Text
                    .Cells(lngZeile, 4).Value = cmtDieser.Shape.Fill.Transparency
                End If
            Next
    End With
End Sub

[TxbyFmjy]

dann mach doch einen button der per VBA die Eingabe des "Kommentars" erfasst, im "Kommentar-Tabellenblatt" speichert und den Hyperlink einfügt
evtl könnte auch auf einen bereits vorhanden Kommentar verwiesen werden, oder "Standardkommentare" angeboten werden

Gut Ding braucht Weile.

Um das Einfügen des Hyperlinks zu schaffen, ist es notwendig nicht nur die Adresse der Zelle, die ein Kommentar hat, in eine neue Tabelle zu schreiben, sondern auch die zugehörige Adresse in der neuen Tabelle:

Code:

Option Explicit
Sub KommentareInNeuesBlattSchreiben_1()
    Dim wksMitKommentaren As Worksheet       '(Tabelle1 mit Kommentaren)
    Dim wksAusdruck As Worksheet             '(Tabelle2 zum Ausdrucken)
    Dim cmtDieser As Comment                 'ein Kommentar
    Dim lngZeile As Long
    Dim WatchRange As Range
       
    Set wksMitKommentaren = ActiveSheet                     'Achtung, vorher merken, weil neues Blatt kommt
    Set wksAusdruck = ThisWorkbook.Worksheets.Add()         'macht eine neue Tabelle
   
    Set WatchRange = wksMitKommentaren.Range("C:C")         'nacheinander Tabellenspalte ändern

    With wksAusdruck
                    'Titelzeile schreiben:
                    lngZeile = 1
                    'vor jeden führenden Punkt wird wksAusdruck gesetzt wegen "With"
                    .Cells(lngZeile, 1).Value = "Adresse1"
                    .Cells(lngZeile, 2).Value = "Adresse2"
                    .Cells(lngZeile, 3).Value = "Zellwert"
                    .Cells(lngZeile, 4).Value = "Kommentar"
                    .Cells(lngZeile, 5).Value = "Transparenz"
                    .Rows(lngZeile).Font.Bold = True                'Titelzeile fett machen
   
            For Each cmtDieser In wksMitKommentaren.Comments
                If Not Intersect(cmtDieser.Parent, WatchRange) Is Nothing Then
                    lngZeile = lngZeile + 1
                    .Cells(lngZeile, 1).Value = "A" & lngZeile                        'Adresse1: zum Kommentar zugehörige Adresse in der neuen Tabelle2
                    .Cells(lngZeile, 2).Value = cmtDieser.Parent.AddressLocal         'Adresse2: Adresse der Zelle in Tabelle1, die ein Kommentar hat
                    .Cells(lngZeile, 3).Value = cmtDieser.Parent.Value
                    .Cells(lngZeile, 4).Value = cmtDieser.Text
                    .Cells(lngZeile, 5).Value = cmtDieser.Shape.Fill.Transparency
                End If
            Next
    End With
End Sub

Die Hyperlinks lassen sich dann folgendermaßen realisieren:

In Tabelle1 ist manuell jeweils eine leere Spalte für die Hyperlinks einzufügen. Die Adresse1 in Tabelle2 ist entsprechend anzupassen, weil beim Einfügen des Hyperlinks der Zelleninhalt überschrieben wird.

Code:

Sub HyperlinkaufandereTabelleeinfügen_1()

    Range(CStr(Sheets("Tabelle2").Cells(2, 2))).Select
    'Tabelle2: entsprechend anpassen
    ' Tabelle1 mit den Kommentaren ist ActiveSheet
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="" & "Tabelle2!" & CStr(Sheets("Tabelle2").Cells(2, 1)) _
        , TextToDisplay:=CStr(Sheets("Tabelle2").Cells(2, 1))

End Sub

Die Schleife für die Erstellung aller Links einer Spalte fehlt noch.

[TxbyFmjy]

Nachfolgender halbautomatischer Weg:

Mit nachfolgendem Code lassen sich die Kommentare zu jeder einzelnen Spalte der Tabelle1 mit Kommentaren auf jeweils ein neues Tabellenblatt "Kommentare_Spalte_C" usw. schreiben:

Tabellenname und Spalte sind vor der Ausführung des Makros entsprechend anzupassen.

Code:

Sub KommentareInNeuesBlattSchreiben_2()
    Dim wksMitKommentaren As Worksheet  'die Tabelle mit Kommentaren
    Dim wksAusdruck As Worksheet        'die Tabelle zum Ausdrucken
    Dim cmtDieser As Comment            'ein Kommentar
    Dim lngZeile As Long
    Dim WatchRange As Range
   
    Set wksMitKommentaren = ActiveSheet             'Achtung, vorher merken, weil neues Blatt kommt
    Set wksAusdruck = ThisWorkbook.Worksheets.Add() 'macht eine neue Tabelle
    ActiveSheet.Name = "Kommentare_Spalte_C"        'Tabellenname passend zur Spalte ändern

    Set WatchRange = wksMitKommentaren.Range("C:C") 'nacheinander Tabellenspalte ändern

    With wksAusdruck
                    'Titelzeile schreiben:
                    lngZeile = 1
                    .Cells(lngZeile, 1).Value = "Adresse1"           'vor jeden führenden Punkt wird wksAusdruck gesetzt wegen "With"
                    .Cells(lngZeile, 2).Value = "Adresse2"
                    .Cells(lngZeile, 3).Value = "Zellwert"
                    .Cells(lngZeile, 4).Value = "Kommentar"
                    .Cells(lngZeile, 5).Value = "Transparenz"
                    .Rows(lngZeile).Font.Bold = True                'Titelzeile fett machen

    For Each cmtDieser In wksMitKommentaren.Comments
                 If Not Intersect(cmtDieser.Parent, WatchRange) Is Nothing Then
                      lngZeile = lngZeile + 1
                     .Cells(lngZeile, 1).Value = "A" & lngZeile
                     .Cells(lngZeile, 2).Value = cmtDieser.Parent.AddressLocal
                     .Cells(lngZeile, 3).Value = cmtDieser.Parent.Value
                     .Cells(lngZeile, 4).Value = cmtDieser.Text
                     .Cells(lngZeile, 5).Value = cmtDieser.Shape.Fill.Transparency
                End If
            Next
    End With
End Sub

Mit nachfolgendem Code lassen sich die Hyperlinks in die Tabelle1 mit den Kommentaren schreiben:

In Tabelle1 mit den Kommentaren ist manuell jeweils eine leere Spalte für die Hyperlinks einzufügen, weil beim Einfügen der Hyperlinks der Zelleninhalt überschrieben wird. Die Adresse2 in der Tabelle "Kommentare_Spalte_C" usw. ist vor der Ausführung des Makros entsprechend anzupassen.

Code:

Sub HyperlinkaufandereTabelleeinfügen_2()
    'Tabellenname passend zu Spalte ändern
    Dim lngZeile As Long
    With Worksheets("Kommentare_Spalte_C")
        For lngZeile = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
            Range(CStr(Sheets("Kommentare_Spalte_C").Cells(lngZeile, 2))).Select
            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="" & "Kommentare_Spalte_C!" & CStr(Sheets("Kommentare_Spalte_C").Cells(lngZeile, 1)) _
            , TextToDisplay:=CStr(Sheets("Kommentare_Spalte_C").Cells(lngZeile, 1))
        Next
    End With
End Sub

[TxbyFmjy]

Es darf kein Blattschutz und/oder Arbeitsmappenschutz aktiv sein.

Hat der Name der Quelltabelle ein Leerzeichen ist es für den Ablauf des Makros kein Problem, aber der neue Name der Kommentartabelle darf keine Leerzeichen beinhalten und nicht zu lange sein.

Das Makro fragt den Namen der Quelltabelle ab, den neuen Namen der neuen Kommentartabelle, kopiert die Kommentare der Quelltabelle in die Kommentartabelle und fügt in der Quelltabelle Spalten ein, in die die Hyperlinks auf die Kommentartabelle eingefügt werden:

Code:

Option Explicit
Private wsSource As Worksheet
Private wsNew As Worksheet
Private wsSourcename As Variant
Private wsNewname As Variant
Sub Zelle_Kommentar_neueSpalte_Hyperlink()
Dim varEingabewsSource As Variant
Dim varEingabewsNew As Variant
varEingabewsSource = InputBox("Name der Quelltabelle?")
varEingabewsNew = InputBox("Name der Kommentartabelle?")
wsSourcename = varEingabewsSource
wsNewname = varEingabewsNew
Call Spalteneinfügen_Call
Call PrintCommentsByColumn_alleSpalten_Call
Call HyperlinkAdresse_Call
Call HyperlinkaufandereTabelleeinfügen_Call
End Sub
Private Sub Spalteneinfügen_Call()
Dim cell As Range
Dim myrange As Range, myrangeC As Range
Dim col1 As Long
Dim i As Long
Dim j As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Worksheets(wsSourcename).Activate
If ActiveSheet.Comments.Count = 0 Then
MsgBox "Keine Kommentare in der Tabelle"
Exit Sub
End If
For col1 = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
i = 0
Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col1), _
Cells.SpecialCells(xlCellTypeComments))
If myrangeC Is Nothing Then GoTo nxtCol ' Keine Kommentare in einer Spalte --> nächste Spalte
For Each cell In myrangeC
On Error GoTo LabelC
If Trim(cell.Comment.Text) <> "" Then ' Zelle mit Kommentar
i = i + 1
' Sobald in einer Spalte die erste Zelle mit Kommentar (i = 1) ermittelt wurde,
' selektiere die Zelle in der Spalte rechts davon und füge eine Spalte ein.
If i = 1 Then
Range(cell.Address(0, 0)).Select
ActiveCell.Offset(0, i).Select
ActiveCell.EntireColumn.Insert
Else: GoTo nxtCol ' Es wird nach jeder Spalte mit Kommentar nur eine leere Spalte eingefügt.
End If
End If

LabelB:
On Error GoTo 0 ' error handling aktivieren
Next cell

nxtCol:
On Error GoTo 0 ' error handling aktivieren
Next col1

LabelC:
If col1 = 0 Then GoTo LabelD
j = j + 1
If j = 1 And Err > 0 Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
If Err > 0 Then Debug.Print "     "; j, "          "; cell.MergeArea.Address, "                 "; Err.Number, ""; Err.Description
Resume LabelB

LabelD:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0 ' error handling aktivieren
End Sub
Private Sub PrintCommentsByColumn_alleSpalten_Call()
Dim cell As Range
Dim myrange As Range, myrangeC As Range
Dim col As Long
Dim RowOS As Long
Dim j As Long
If ActiveSheet.Comments.Count = 0 Then
MsgBox "No comments in entire sheet"
Exit Sub
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsSource = Worksheets(wsSourcename)
Set wsSource = ActiveSheet
Sheets.Add
Set wsNew = ActiveSheet
ActiveSheet.Name = wsNewname
wsSource.Activate
With wsNew.Columns("A:E")
.VerticalAlignment = xlTop
.WrapText = True
End With
wsNew.Columns("A").ColumnWidth = 10
wsNew.Columns("B").ColumnWidth = 10
wsNew.Columns("C").ColumnWidth = 15
wsNew.Columns("D").ColumnWidth = 60
wsNew.PageSetup.PrintGridlines = True
RowOS = 2
wsNew.Cells(1, 1) = "Adresse1"
wsNew.Cells(1, 1).Font.Bold = True
wsNew.Cells(1, 2) = "Adresse2"
wsNew.Cells(1, 2).Font.Bold = True
wsNew.Cells(1, 3) = "Zellwert"
wsNew.Cells(1, 3).Font.Bold = True
wsNew.Cells(1, 4) = "Kommentar"
wsNew.Cells(1, 4).Font.Bold = True
For col = 1 To ActiveSheet.UsedRange.Columns.Count
Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col), _
Cells.SpecialCells(xlCellTypeComments))
If myrangeC Is Nothing Then GoTo nxtCol
For Each cell In myrangeC
On Error GoTo LabelC
If Trim(cell.Comment.Text) <> "" Then
RowOS = RowOS + 1
wsNew.Cells(RowOS, 1) = "A" & RowOS
wsNew.Cells(RowOS, 2) = cell.Address(0, 0)
wsNew.Cells(RowOS, 3) = cell.Text
wsNew.Cells(RowOS, 4) = cell.Comment.Text
End If

LabelB:
On Error GoTo 0 ' error handling aktivieren
Next cell

nxtCol:
On Error GoTo 0 ' error handling aktivieren
Next col

LabelC:
If col > ActiveSheet.UsedRange.Columns.Count Then GoTo LabelD
j = j + 1
If j = 1 And cell.MergeCells = True Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
If Err > 0 Then Debug.Print "     "; j, "          "; cell.MergeArea.Address, "                 "; Err.Number, ""; Err.Description
Resume LabelB

LabelD:
wsNew.Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0 ' error handling aktivieren
End Sub
Private Sub HyperlinkAdresse_Call()
Dim rngZelle As Range
Dim lngZeile As Long
Dim varEingabe As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsNew = Worksheets(wsNewname)
Set wsNew = ActiveSheet
With ActiveSheet
    lngZeile = .Range("B" & Rows.Count).End(xlUp).Row
    For Each rngZelle In .Range("B3:B" & lngZeile)
        rngZelle.Value = NTC(rngZelle.Value)
    Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Public Function NTC(Optional ByVal Header As Variant, Optional ByVal Zahl As Integer) As String
Dim i As Integer

If Header = "" Then GoTo Weiter
Zahl = Range(Range(Header & "1").Address).Column + 1

Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
If Zahl <= 0 Or Zahl > 16384 Then Exit Function
NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0) & Range(Range(Header).Address).Row
End Function
Private Sub HyperlinkaufandereTabelleeinfügen_Call()
Dim lngZeile As Long
Worksheets(wsSourcename).Activate
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    With ActiveWorkbook.Worksheets(wsNewname)
        For lngZeile = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
            Range(CStr(Sheets(wsNewname).Cells(lngZeile, 2))).Select
            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="" & (wsNewname & "!") & CStr(Sheets(wsNewname).Cells(lngZeile, 1)) _
            , TextToDisplay:=CStr(Sheets(wsNewname).Cells(lngZeile, 1))
        Next
    End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[TxbyFmjy]

Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle

Hallo,

du verwendest den Namen eines Arbeitsblattes (=Kommentartabelle) in einem Hyperlink
          ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", _
            SubAddress:=wsNewname & "!" & CStr(Sheets(wsNewname).Cells(lngZeile, 1)), _
            TextToDisplay:=CStr(Sheets(wsNewname).Cells(lngZeile, 1))

Ist in der Variablen "wsNewname" ein Leerzeichen enthalten, so gibt es ein Problem. Einen solchen Namen musst du zwingend mit Hochkommas begrenzen:
          ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", _
            SubAddress:="'" & wsNewname & "'!" & CStr(Sheets(wsNewname).Cells(lngZeile, 1)), _
            TextToDisplay:=CStr(Sheets(wsNewname).Cells(lngZeile, 1))

Es darf kein Blattschutz und/oder Arbeitsmappenschutz aktiv sein.

Das Makro fragt den Namen der Quelltabelle ab, den neuen Namen der neuen Kommentartabelle, kopiert die Kommentare der Quelltabelle in die Kommentartabelle und fügt in der Quelltabelle Spalten ein, in die die Hyperlinks auf die Kommentartabelle eingefügt werden:

Code:

Option Explicit

Private wsSource As Worksheet
Private wsNew As Worksheet
Private wsSourcename As Variant
Private wsNewname As Variant

Sub Zelle_Kommentar_neueSpalte_Hyperlink()
Dim varEingabewsSource As Variant
Dim varEingabewsNew As Variant
varEingabewsSource = InputBox("Name der Quelltabelle?")
varEingabewsNew = InputBox("Name der Kommentartabelle?")
wsSourcename = varEingabewsSource
wsNewname = varEingabewsNew
Call Spalteneinfügen_Call
Call PrintCommentsByColumn_alleSpalten_Call
Call HyperlinkAdresse_Call
Call HyperlinkaufandereTabelleeinfügen_Call
End Sub

Code:

Private Sub Spalteneinfügen_Call()
Dim cell As Range
Dim myrange As Range, myrangeC As Range
Dim col1 As Long
Dim i As Long
Dim j As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Worksheets(wsSourcename).Activate
If ActiveSheet.Comments.Count = 0 Then
MsgBox "Keine Kommentare in der Tabelle"
Exit Sub
End If
For col1 = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
i = 0
Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col1), _
Cells.SpecialCells(xlCellTypeComments))
If myrangeC Is Nothing Then GoTo nxtCol ' Keine Kommentare in einer Spalte --> nächste Spalte
For Each cell In myrangeC
On Error GoTo LabelC
If Trim(cell.Comment.Text) <> "" Then ' Zelle mit Kommentar
i = i + 1
' Sobald in einer Spalte die erste Zelle mit Kommentar (i = 1) ermittelt wurde,
' selektiere die Zelle in der Spalte rechts davon und füge eine Spalte ein.
If i = 1 Then
Range(cell.Address(0, 0)).Select
ActiveCell.Offset(0, i).Select
ActiveCell.EntireColumn.Insert
Else: GoTo nxtCol ' Es wird nach jeder Spalte mit Kommentar nur eine leere Spalte eingefügt.
End If
End If

LabelB:
On Error GoTo 0 ' error handling aktivieren
Next cell

nxtCol:
On Error GoTo 0 ' error handling aktivieren
Next col1

LabelC:
If col1 = 0 Then GoTo LabelD
j = j + 1
If j = 1 And Err > 0 Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
If Err > 0 Then Debug.Print "     "; j, "          "; cell.MergeArea.Address, "                 "; Err.Number, ""; Err.Description
Resume LabelB

LabelD:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0 ' error handling aktivieren
End Sub

Code:

Private Sub PrintCommentsByColumn_alleSpalten_Call()
Dim cell As Range
Dim myrange As Range, myrangeC As Range
Dim col As Long
Dim RowOS As Long
Dim j As Long
If ActiveSheet.Comments.Count = 0 Then
MsgBox "No comments in entire sheet"
Exit Sub
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsSource = Worksheets(wsSourcename)
Set wsSource = ActiveSheet
Sheets.Add
Set wsNew = ActiveSheet
ActiveSheet.Name = wsNewname
wsSource.Activate
With wsNew.Columns("A:E")
.VerticalAlignment = xlTop
.WrapText = True
End With
wsNew.Columns("A").ColumnWidth = 10
wsNew.Columns("B").ColumnWidth = 10
wsNew.Columns("C").ColumnWidth = 15
wsNew.Columns("D").ColumnWidth = 60
wsNew.PageSetup.PrintGridlines = True
RowOS = 2
wsNew.Cells(1, 1) = "Adresse1"
wsNew.Cells(1, 1).Font.Bold = True
wsNew.Cells(1, 2) = "Adresse2"
wsNew.Cells(1, 2).Font.Bold = True
wsNew.Cells(1, 3) = "Zellwert"
wsNew.Cells(1, 3).Font.Bold = True
wsNew.Cells(1, 4) = "Kommentar"
wsNew.Cells(1, 4).Font.Bold = True
For col = 1 To ActiveSheet.UsedRange.Columns.Count
Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col), _
Cells.SpecialCells(xlCellTypeComments))
If myrangeC Is Nothing Then GoTo nxtCol
For Each cell In myrangeC
On Error GoTo LabelC
If Trim(cell.Comment.Text) <> "" Then
RowOS = RowOS + 1
wsNew.Cells(RowOS, 1) = "A" & RowOS
wsNew.Cells(RowOS, 2) = cell.Address(0, 0)
wsNew.Cells(RowOS, 3) = cell.Text
wsNew.Cells(RowOS, 4) = cell.Comment.Text
End If

LabelB:
On Error GoTo 0 ' error handling aktivieren
Next cell

nxtCol:
On Error GoTo 0 ' error handling aktivieren
Next col

LabelC:
If col > ActiveSheet.UsedRange.Columns.Count Then GoTo LabelD
j = j + 1
If j = 1 And cell.MergeCells = True Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
If Err > 0 Then Debug.Print "     "; j, "          "; cell.MergeArea.Address, "                 "; Err.Number, ""; Err.Description
Resume LabelB

LabelD:
wsNew.Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0 ' error handling aktivieren
End Sub

Code:

Private Sub HyperlinkAdresse_Call()
Dim rngZelle As Range
Dim lngZeile As Long
Dim varEingabe As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsNew = Worksheets(wsNewname)
Set wsNew = ActiveSheet
With ActiveSheet
    lngZeile = .Range("B" & Rows.Count).End(xlUp).Row
    For Each rngZelle In .Range("B3:B" & lngZeile)
        rngZelle.Value = NTC(rngZelle.Value)
    Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Code:

Public Function NTC(Optional ByVal Header As Variant, Optional ByVal Zahl As Integer) As String
Dim i As Integer

If Header = "" Then GoTo Weiter
Zahl = Range(Range(Header & "1").Address).Column + 1

Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
If Zahl <= 0 Or Zahl > 16384 Then Exit Function
NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0) & Range(Range(Header).Address).Row
End Function

korrigiert: Hochkomma (Apostroph) hinzugefügt

Code:

"'" & wsNewname & "'!"

Code:

Private Sub HyperlinkaufandereTabelleeinfügen_Call()
Dim lngZeile As Long
Worksheets(wsSourcename).Activate
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    With ActiveWorkbook.Worksheets(wsNewname)
        For lngZeile = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
            Range(CStr(Sheets(wsNewname).Cells(lngZeile, 2))).Select
            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & wsNewname & "'!" & CStr(Sheets(wsNewname).Cells(lngZeile, 1)) _
            , TextToDisplay:=CStr(Sheets(wsNewname).Cells(lngZeile, 1))
        Next
    End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

  cell comment hyperlink (korr).xlsm (Größe: 144,26 KB / Downloads: 1)

[TxbyFmjy]

... und nun, wie weiter?

Da muss ich noch einmal genauer hinschauen:

ActiveSheet.UsedRange.Columns.Count - 8 what does it mean?

ActiveSheet.UsedRange.select

Seems like you want to move around. Try this:

    ActiveSheet.UsedRange.select

results in.... 

   

If you want to move that selection 3 rows up then try this

    ActiveSheet.UsedRange.offset(-3).select

does this...

   

To find the last column which has data, use .Find

BernardSaucier has already given you an answer. My post is not an answer but an explanation as to why you shouldn't be using `UsedRange`.

`UsedRange` is highly unreliable as shown HERE

To find the last column which has data, use `.Find` and then subtract from it.

Code:

    With Sheets("Sheet1")
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastCol = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column
        Else
            lastCol = 1
        End If
    End With
   
    If lastCol > 8 Then
        'Debug.Print ActiveSheet.UsedRange.Columns.Count - 8
       
        'The above becomes
       
        Debug.Print lastCol - 8
    End If

Gewollt ist, dass alle Kommentare einer beliebigen Quelltabelle in eine neue Kommentartabelle kopiert und in dieser Quelltabelle für alle kopierten Kommentare Hyperlinks auf diese neue Kommentartabelle eingefügt werden.

Angepasst an das Gewollte meines Schnipsels, sollte die Entwicklung folgendermaßen weiter vorangetrieben werden:

In Private Sub Spalteneinfügen_Call()

Code:

Dim lastCol1 As Integer

Code:

With Sheets(wsSourcename)
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastCol1 = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Column
    Else
        lastCol1 = 1
    End If
End With

Code:

For col1 = lastCol1 To 1 Step -1

i = 0

Set myrangeC = Intersect(Columns(col1), _
Cells.SpecialCells(xlCellTypeComments))

sowie

in Private Sub PrintCommentsByColumn_alleSpalten_Call()

Code:

Dim lastCol As Integer

Code:

With Sheets(wsSourcename)
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastCol = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Column
    Else
        lastCol = 1
    End If
End With

Code:

For col = 1 To lastCol

Set myrangeC = Intersect(Columns(col), _
Cells.SpecialCells(xlCellTypeComments))

Sobald meine Tests abgeschlossen sind, melde ich mich wieder.

[TxbyFmjy]

Kommentare in neue Kommentartabelle kopieren, in der Quelltabelle einfügen von Hyperlinks auf die Kommentare in der Kommentartabelle

Hallo,

ich habe recherchiert, dass die Private Function NTC ihren Ursprung in einer anderen Aufgabenstellung hat.

Sowohl die Variable "Header" als auch die Variable "Zahl" haben in der anderen Aufgabenstellung eine Bedeutung, weil im Originalcode für die Variable "Header" (Spaltenüberschrift) oder die Variable "Zahl" in beiden Fällen jeweils die Spaltenbezeichnung zurückgegeben wird.

Originalcode (Suche im WWW nach "bei target.offset statt Spaltenindex die Spaltenüberschrift")

Code:

Function NTC(Optional ByVal Header As String, Optional ByVal Zahl As Integer) As String
Dim I As Integer
Dim acol As Long
Dim Bereich As Range, RNG As Range

If Header = "" Then GoTo Weiter
acol = Cells(1, Columns.Count).End(xlToLeft).Column
Set Bereich = Range(Range("A1"), Cells(1, acol))
Set RNG = Bereich.Find(What:=Header, LookIn:=xlValues, LookAt:=xlWhole)
    If Not RNG Is Nothing Then
        Zahl = Range(RNG.Address).Column
    End If

Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
If Zahl <= 0 Or Zahl > 16384 Then Exit Function
NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0)
End Function

Code:

Sub Hohls()
MsgBox NTC(Header:="DeinHeader")
MsgBox NTC(Zahl:=16384)
End Sub

Es wird dann beide male die Spaltenbezeichnung zurückgegeben.

Aus diesem Grund habe ich die Private Function NTC für diese Aufgabenstellung korrigiert:

Code:

Public Function NTC(Zellenwert As String) As String
Dim i As Integer
Dim Zahl As Integer

If Zellenwert = "" Then GoTo Weiter
Zahl = Range(Range(Zellenwert & "1").Address).Column + 1

Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
If Zahl <= 0 Or Zahl > 16384 Then Exit Function
NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0) & Range(Range(Zellenwert).Address).Row
End Function

Das dort erklärte, habe ich auch noch korrigiert.

Tutti completti:

Es sind selbstverständlich noch Code-Optimierungen möglich und nöitg, aber das Grundgerüst steht und funktioiniert jetzt. Alle Kommentare einer beliebigen Quelltabelle werden in eine neue Kommentartabelle kopiert und in der Quelltabelle für alle Kommentare Hyperlinks auf die Kommentartabelle eingefügt.

Code:

Option Explicit

Private wsSource As Worksheet
Private wsNew As Worksheet
Private wsSourcename As Variant
Private wsNewname As Variant

Sub Zelle_Kommentar_neueSpalte_Hyperlink()
Dim varEingabewsSource As Variant
Dim varEingabewsNew As Variant
varEingabewsSource = InputBox("Name der Quelltabelle?")
varEingabewsNew = InputBox("Name der Kommentartabelle?")
wsSourcename = varEingabewsSource
wsNewname = varEingabewsNew
Call Spalteneinfügen_Call
Call PrintCommentsByColumn_alleSpalten_Call
Call HyperlinkAdresse_Call
Call HyperlinkaufandereTabelleeinfügen_Call
End Sub

Code:

Private Sub Spalteneinfügen_Call()
Dim cell As Range
Dim myrange As Range, myrangeC As Range
Dim col1 As Long
Dim i As Long
Dim j As Long
Dim lastCol1 As Integer

Worksheets(wsSourcename).Activate

If ActiveSheet.Comments.Count = 0 Then
MsgBox "Keine Kommentare in der Tabelle"
Exit Sub
End If

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets(wsSourcename)
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastCol1 = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Column
    Else
        lastCol1 = 1
    End If
End With

For col1 = lastCol1 To 1 Step -1

i = 0

Set myrangeC = Intersect(Columns(col1), _
Cells.SpecialCells(xlCellTypeComments))

If myrangeC Is Nothing Then GoTo nxtCol ' Keine Kommentare in einer Spalte --> nächste Spalte
For Each cell In myrangeC
On Error GoTo LabelC
If Trim(cell.Comment.Text) <> "" Then ' Zelle mit Kommentar
i = i + 1
' Sobald in einer Spalte die erste Zelle mit Kommentar (i = 1) ermittelt wurde,
' selektiere die Zelle in der Spalte rechts davon und füge eine Spalte ein.
If i = 1 Then
Range(cell.Address(0, 0)).Select
ActiveCell.Offset(0, i).Select
ActiveCell.EntireColumn.Insert
Else: GoTo nxtCol ' Es wird nach jeder Spalte mit Kommentar nur eine leere Spalte eingefügt.
End If
End If

LabelB:
On Error GoTo 0 ' error handling aktivieren
Next cell

nxtCol:
On Error GoTo 0 ' error handling aktivieren
Next col1

LabelC:
If col1 = 0 Then GoTo LabelD
j = j + 1
If j = 1 And Err > 0 Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
If Err > 0 Then Debug.Print "    "; j, "          "; cell.MergeArea.Address, "                "; Err.Number, ""; Err.Description
Resume LabelB

LabelD:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0 ' error handling aktivieren
End Sub

Code:

Private Sub PrintCommentsByColumn_alleSpalten_Call()
Dim cell As Range
Dim myrange As Range, myrangeC As Range
Dim col As Long
Dim RowOS As Long
Dim j As Long
Dim lastCol As Integer

If ActiveSheet.Comments.Count = 0 Then
MsgBox "No comments in entire sheet"
Exit Sub
End If

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Sheets(wsSourcename)
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastCol = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Column
    Else
        lastCol = 1
    End If
End With

Set wsSource = Worksheets(wsSourcename)
Set wsSource = ActiveSheet
Sheets.Add
Set wsNew = ActiveSheet
ActiveSheet.Name = wsNewname
wsSource.Activate
With wsNew.Columns("A:E")
.VerticalAlignment = xlTop
.WrapText = True
End With
wsNew.Columns("A").ColumnWidth = 10
wsNew.Columns("B").ColumnWidth = 10
wsNew.Columns("C").ColumnWidth = 15
wsNew.Columns("D").ColumnWidth = 60
wsNew.PageSetup.PrintGridlines = True
RowOS = 2
wsNew.Cells(1, 1) = "Adresse1"
wsNew.Cells(1, 1).Font.Bold = True
wsNew.Cells(1, 2) = "Adresse2"
wsNew.Cells(1, 2).Font.Bold = True
wsNew.Cells(1, 3) = "Zellwert"
wsNew.Cells(1, 3).Font.Bold = True
wsNew.Cells(1, 4) = "Kommentar"
wsNew.Cells(1, 4).Font.Bold = True

For col = 1 To lastCol

Set myrangeC = Intersect(Columns(col), _
Cells.SpecialCells(xlCellTypeComments))

If myrangeC Is Nothing Then GoTo nxtCol
For Each cell In myrangeC
On Error GoTo LabelC
If Trim(cell.Comment.Text) <> "" Then
RowOS = RowOS + 1
wsNew.Cells(RowOS, 1) = "A" & RowOS
wsNew.Cells(RowOS, 2) = cell.Address(0, 0)
wsNew.Cells(RowOS, 3) = cell.Text
wsNew.Cells(RowOS, 4) = cell.Comment.Text
End If

LabelB:
On Error GoTo 0 ' error handling aktivieren
Next cell

nxtCol:
On Error GoTo 0 ' error handling aktivieren
Next col

LabelC:
If col > ActiveSheet.UsedRange.Columns.Count Then GoTo LabelD
j = j + 1
If j = 1 And cell.MergeCells = True Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
If Err > 0 Then Debug.Print "    "; j, "          "; cell.MergeArea.Address, "                "; Err.Number, ""; Err.Description
Resume LabelB

LabelD:
wsNew.Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0 ' error handling aktivieren
End Sub

Code:

Private Sub HyperlinkAdresse_Call()
Dim rngZelle As Range
Dim lngZeile As Long
Dim varEingabe As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsNew = Worksheets(wsNewname)
Set wsNew = ActiveSheet
With ActiveSheet
    lngZeile = .Range("B" & Rows.Count).End(xlUp).Row
    For Each rngZelle In .Range("B3:B" & lngZeile)
        rngZelle.Value = NTC(rngZelle.Value)
    Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Code:

Public Function NTC(Zellenwert As String) As String
Dim i As Integer
Dim Zahl As Integer

If Zellenwert = "" Then GoTo Weiter
Zahl = Range(Range(Zellenwert & "1").Address).Column + 1

Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
If Zahl <= 0 Or Zahl > 16384 Then Exit Function
NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0) & Range(Range(Zellenwert).Address).Row
End Function

Code:

Private Sub HyperlinkaufandereTabelleeinfügen_Call()
Dim lngZeile As Long
Worksheets(wsSourcename).Activate
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    With ActiveWorkbook.Worksheets(wsNewname)
        For lngZeile = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
            Range(CStr(Sheets(wsNewname).Cells(lngZeile, 2))).Select
            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & wsNewname & "'!" & CStr(Sheets(wsNewname).Cells(lngZeile, 1)) _
            , TextToDisplay:=CStr(Sheets(wsNewname).Cells(lngZeile, 1))
        Next
    End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

  cell comment hyperlink (korr 2).xlsm (Größe: 145,04 KB / Downloads: 2)

[TxbyFmjy]

In Private Sub HyperlinkAdresse_Call() ist Dim varEingabe As Variant überflüssig und wurde gelöscht.


  cell comment hyperlink (korr 3).xlsm (Größe: 145,03 KB / Downloads: 2)