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

[Achille]

Hallo,

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:

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

cell comment hyperlink.xlsm

 

[Achille]

Hallo Holger,

Funktion NTC

Da mir die Daten nicht vorliegen, kann ich zur Vorgehensweise nichts sagen. Nur sollte man entweder deutsche (Zahl) oder englische (Header) Begriffe beim Aufruf verwenden.

Wenn Header die Angabe der Spalte ist, führt bei mir

Range(Header & 1).Column + 1

zum gleichen Ergebnis wie

Range(Range(Header & "1").Address).Column + 1

Ciao,
Holger

Und zur Info für alle, die es interessiert:

Um das zu verstehen, habe ich das Makro in cell comment hyperlink (korr_2).xlsm mit der Quelltabelle "Tabelle5" und der Kommentartabelle "K Tab5" bis zur Stoppmarke "Call HyperlinkAdresse_Call" laufen lassen und von dort an in Einzelschritten mit "F8" fortgesetzt.

Tabelle5

Das Ergebnis an der Stoppmarke "Call HyperlinkAdresse_Call" sieht folgendermaßen aus:

Header ist nicht die Angabe der Spalte, sondern Header ist "rngZelle.Value" [rngZelle.Value = NTC(rngZelle.Value)], also "F32", usw. Aus "F32" wird "G32", die Zelle, in die nach "Call HyperlinkAdresse_Call" mittels "Call HyperlinkaufandereTabelleeinfügen_Call" der Hyperlink in die Quelltabelle kopiert wird.

Man soll nicht päpstlicher sein als der Papst, erst recht nicht als Laie, aber "Header" erscheint mir eine "irreführende" Bezeichnung zu sein, weil unter Header in Excel-VBA üblicherweise etwas anderes verstanden wird, als wie in diesem Fall der an die Public Function NTC übergebene Zellinhalt einer bestimmten Zelle.

 

[Achille]

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")

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

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 das Makro NTC für diese Aufgabenstellung korrigiert:

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

cell comment hyperlink (korr_3).xlsm

 

[Achille]

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

cell comment hyperlink (korr_4).xlsm