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]

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.

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

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

 

[HaHoBe]

Hallo Achiille,

aufgrund des hier geposteten Codes möchte ich meine Gedanken dazu in den Ring werfen, auch wenn ich keine Frage erkennen kann.

Zuerst einmal: ich würde mir durchgängig entweder deutsche oder englische Variablennamen wünschen. Und das sagt einer, der im Glashaus sitzt.

In den geposteten Codes bin ich bis zur vierten Zeile gekommen, und bereits da habe ich vermutet, dass diese Codes nichts für mich wären. Dort wird die Variable wsSourcename modulweit angelegt, und zwar vom Typ Variant. Laut Reddick steht das Präfix ws für Worksheet, es handelt sich bei dem Namen einer Tabelle in aller Regel um einen Text/String, aber keineswegs um ein Tabellenblatt.

Zur ersten Prozedur: Du verwendest zur Ermittlung der Namen der Tabellen Inputboxen. Diese kann man einsetzen, sie haben aber einige Nachteile. Du stellst keinerlei Überprüfung an, ob vielleicht die Schaltfläche Abbrechen gedrückt wurde (das knallt dann wegen eines fehlenden Wertes in der nächsten Prozedur) oder ob sich die Datentabelle mit dem Namen (Tippfehler – ich bin Spezialist dafür) in der Mappe befindet.

Private wsSource As Worksheet
Private wsNew As Worksheet
Private wsSourcename As Variant   '### Präfix und Datentyp unterscheiden sich
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?")
'### Für beide Eingaben gilt, dass keinerlei Prüfung erfolgt.
'### Die Möglichkeit "Abbrechen" wird ebenso wenig wie das
'###    versehentliche Drücken von "OK" ohne Eingabe überprüft.
'### Es erfolgt nach Eingabe für den Namen der Datentabelle
'### keine Prüfung, ob sich diese Tabelle in der Mappe befindet
'### oder ein Schreibfehler vorliegt
wsSourcename = varEingabewsSource
wsNewname = varEingabewsNew
Call SpaltenEinfügen_Call
Call PrintCommentsByColumn_alleSpalten_Call
Call HyperlinkAdresse_Call
Call HyperlinkaufandereTabelleeinfügen_Call
End Sub

Mögliche Alternativen: Zählen der Arbeitsblätter in der Mappe. Gibt es nur eines, ist die Datentabelle damit festgelegt. Gibt es mehrere, könnte man einen Text bilden, der aus dem Index der Tabellen und dem Namen besteht, wobei der Benutzer dann die Zahl einzugeben hätte, um die Tabelle zu benennen. Auch bei diesem Vorgehen muss überprüft werden, ob Abbrechen gewählt wurde oder eine Zahl, die zulässig ist. Der Aufruf eines Formulars mit zwei Schaltflächen und entweder einem Listen- oder Kombinationsfeld erscheint mir persönlich sicherer. Die Schaltflächen sind für Abbrechen (hier wird die Prozedur abgebrochen, wohingegen die Schaltfläche Weiter erst nach Auswahl einer Tabelle zu benutzen ist.

Als Alternative für die Zieltabelle lässt sich zum Beispiel die Verwendung des Tabellennamens mit Zusatz (Länge von 31 Zeichen beachten!) oder die Verwendung eines festen Begriffes und einem Zeitstempel vorstellen.

Fortsetzung folgt.

Ciao,
Holger

 

[HaHoBe]

Prozedur SpaltenEinfügen_Call

Warum aktivieren und dann auf die aktive Tabelle verweisen? Die Zeile wegen der Umstellung der Berechnung sollte nach der Prüfung eingefügt werden, ob es überhaupt Kommentare auf der Tabelle gibt. Und diese Prüfung sollte eigentlich erfolgen, bevor man bei keinen Kommentaren den Namen einer Zieltabelle abfragt. Idealerweise fragt man zu Beginn des Makros den Status der Berechnung ab und übergibt diesen Wert am Ende wieder.

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
'### Ich frage mich immer, warum zuerst aktiviert werden muss,
'### damit danach mit ActiveSheet auf die Tabelle zugegriffen wird.
'###
'### Denkfehler im Ablauf: zuvor wurde die Berechnung auf manuell
'### umgestellt, "Exit Sub" heißt meines Wissens verlasse die Prozedur,
'### ohne sicherzustellen, dass die Berechnung wieder auf den
'### Ausgangszustand zurückgestellt wurde. Ich bin mir nicht sicher,
'### ob jeder Anwender von dieser Vorgehensweise begeistert ist, wenn
'### man sie ihm nicht mitteilt.

End If
'### ActiveSheet.UsedRange.Columns.Count geht davon aus, dass
'### die Daten in Spalte A beginnen. Tun sie es nicht, werden
'### Spalten des aktiven Bereiches nicht bearbeitet
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
'### MacroRecorder-Code: Erst auswählen, dann versetzen, dann einfügen.
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
'### statt eines Festwertes, auf den die Berechnung zurückgesetzt wird,
'### könnte am Beginn des Makros eine Variable verwendet werden, die die
'### momentane Berechnung aufnimmt und sie am Ende wieder zurückgibt
Application.ScreenUpdating = True
On Error GoTo 0 ' error handling aktivieren
End Sub

Du gehst davon aus, dass die Daten in Spalte A beginnen, tun sie es aber nicht, wird ein Teil der Datentabelle oder des benutzten Bereiches nicht abgefragt. Ist das gewollt?

Und man kann aus den 3 Zeilen zum Einfügen einer Spalte neben derjenigen, die die Kommentare enthält (macht der Makro-Rekorder auch so – ich weiß), auch einen Einzeiler verwenden. Und wenn man einen Kommentar in der Spalte gefunden hat, kann die Schleife für die Spalte verlassen werden und die nächste in Angriff genommen werden.

Fortsetzung folgt., aber nach einer Pause. Schließlich fehlt das Aufzeigen einer anderen Vorgehensweise auch noch.

Ciao,
Holger

 

[HaHoBe]

Prozedur PrintCommentsByColumn_alleSpalten_Call

Der von dieser Prozedur eventuell aufgerufene Text des Mitteilungsfensters ist englisch. Durchgängig sollte er aber wie in der vorhergehenden Prozedur deutsch sein.

Der Variablen wsSource wird in zwei aufeinanderfolgenden Codezeilen ein Objekt zugewiesen. Sicherer ist es meiner Meinung nach, den Namen der Tabelle anzugeben, auch wenn hier durch die vorhergehende Prozedur die entsprechende Tabelle aktiviert wurde.

Bei der Neuanlage der Übersicht würde ich den Code etwas verschlanken. Mehr dazu bei den Änderungsvorschlägen von meiner Seite.

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
'### Text der Mitteilung in englisch statt deutsch???
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsSource = Worksheets(wsSourcename)
Set wsSource = ActiveSheet
'### doppelte Zuweisung, auch wenn durch den Aufruf der vorherigen Prozedur und
'### Anwahl der Tabelle die Ursprungstabelle aktiviert ist.
'### Sicherer ist IMHO die Zuweisung über den Namen der Tabelle
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
'### Auslagerung der Neuanlage bzw. Bereinigung der Übersicht
'### in die erste Prozedur.
'### Feste Spaltenbreiten könnten durch Autofit bzw. Beschränkung
'### der Kommentarlänge in Spalte D auf eine bestimmte Breite ersetzt werden
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
'### statt mit einer definierten Variablen könnte man per
'### With-Anweisung die erste freie Zelle in Spalte A ermitteln
'### und per Offset die Nebenzellen füllen
'### Wozu benötigt man die Zelladresse in Spalte A?
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

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

 

[HaHoBe]

Hallo Achille,

es folgt eine Bearbeitung zumindest der beiden zuerst geposteten Prozeduren.

Private wsDaten As Worksheet
Private wsÜbersicht As Worksheet

Sub Zelle_Kommentar_neueSpalte_Hyperlink()

Dim varNameTabelle    As Variant
Dim varNameListe      As Variant

varNameTabelle = InputBox("Name der Quelltabelle?")
If varNameTabelle = "" Then Exit Sub
If Not Evaluate("ISREF('" & varNameTabelle & "'!A1)") Then
  MsgBox "Keine Tabelle mit dem Namen '" & varNameTabelle & "' in Mappe vorhanden.", vbInformation, "Abbruch"
  Exit Sub
Else
  If Sheets(varNameTabelle).Comments.Count = 0 Then
    MsgBox "Keine Kommentare in Tabelle '" & varNameTabelle & "'", vbInformation, "Nicht zu tun - Abbruch"
    Exit Sub
  End If
End If

varNameListe = InputBox("Name der Kommentartabelle?")
If varNameListe = "" Then Exit Sub

Set wsDaten = Sheets(varNameTabelle)

If Not Evaluate("ISREF('" & varNameListe & "'!A1)") Then
  Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = varNameListe
  Set wsÜbersicht = Sheets(varNameListe)
  With wsÜbersicht.Columns("A:D")
    .VerticalAlignment = xlTop
    .WrapText = True
  End With
  wsÜbersicht.PageSetup.PrintGridlines = True
  With wsÜbersicht.Range("A1:D1")
    .Value = Array("Adresse1", "Adresse2", "Zellwert", "Kommentar")
    .Font.Bold = True
  End With

Else
  Set wsÜbersicht = Sheets(varNameListe)
  wsÜbersicht.Range("A2:D" & Rows.Count).ClearContents
End If

Call SpaltenEinfügen_Call
Call PrintCommentsByColumn_alleSpalten_Call
Call HyperlinkAdresse_Call
Call HyperlinkaufandereTabelleeinfügen_Call

Set wsÜbersicht = Nothing
Set wsDaten = Nothing
End Sub

Private Sub SpaltenEinfügen_Call()

Dim rngZelle As Range
Dim rngKommentar As Range
Dim lngSpalte As Long
Dim lngAnzKomm As Long
Dim lngAnzVerbZellen As Long
Dim lngBerechnung As Long

Application.ScreenUpdating = False
lngBerechnung = Application.Calculation
Application.Calculation = xlCalculationManual

For lngSpalte = wsSource.UsedRange.Cells(wsSource.UsedRange.Cells.Count).Column To 1 Step -1
  lngAnzKomm = 0
  Set rngKommentar = Intersect(wsSource.UsedRange, wsSource.Columns(lngSpalte), _
                                Cells.SpecialCells(xlCellTypeComments))
  If Not rngKommentar Is Nothing Then ' Kommentare in einer Spalte --> nächste Spalte
    For Each rngZelle In rngKommentar
      On Error GoTo Fehler_VerbZellen
      If Trim(rngZelle.Comment.Text) <> "" Then ' Zelle mit Kommentar
        lngAnzKomm = lngAnzKomm + 1
        ' Sobald in einer Spalte die erste Zelle mit Kommentar (lngAnzKomm = 1) ermittelt wurde,
        ' selektiere die Zelle in der Spalte rechts davon und füge eine Spalte ein.
        If lngAnzKomm = 1 Then
          rngZelle.Offset(0, 1).EntireColumn.Insert
          Exit For
        End If
      End If
      On Error GoTo 0 ' error handling aktivieren
    Next rngZelle
   End If
Fehler_VerbZellen:
  If lngSpalte <> 0 Then
    lngAnzVerbZellen = lngAnzVerbZellen + 1
    If lngAnzVerbZellen = 1 And Err > 0 Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
    If Err > 0 Then Debug.Print "     "; lngAnzVerbZellen, "          "; rngZelle.MergeArea.Address, "                 "; Err.Number, ""; Err.Description
  End If
  On Error GoTo 0 ' error handling aktivieren
Next lngSpalte


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

Ciao,
Holger

 

[Achille]

Du gehst davon aus, dass die Daten in Spalte A beginnen, tun sie es aber nicht, wird ein Teil der Datentabelle oder des benutzten Bereiches nicht abgefragt. Ist das gewollt?

Nein, das ist nicht gewollt.

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

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

cell comment hyperlink (korr).xlsm

In cell comment hyperlink (korr).xlsm wurde das Hochkomma (Apostroph) in "'" & wsNewname & "'!" korrigiert. Somit können die Tabellennamen auch Leerzeichen enthalten.

In dieser Arbeitsmappe funktioniert das Gewollte bei Tabelle1, Tabelle2, Tabelle3, aber nicht bei Tabelle4 und Tabelle5

 

[Achille]

Hallo HaHoBe,

herzlichen Dank für Deine Hilfe.

Ich habe jetzt in der Arbeitsmappe cell comment hyperlink (korr).xlsm in

Private Sub Spalteneinfügen_Call() und
Private Sub PrintCommentsByColumn_alleSpalten_Call()

nur ActiveSheet.UsedRange.Columns.Count ersetzt durch ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Column

und festgestellt, dass damit das von mir ursprünglich und lange Zeit nicht erkannte Problem beseitigt wurde.

Deine Vorschläge werde ich nach und nach durcharbeiten.

cell comment hyperlink (korr_2).xlsm

In der Arbeitsmappe cell comment hyperlink (korr_2).xlsm funktioniert das Gewollte bei Tabelle1, Tabelle2, Tabelle3, Tabelle4 und Tabelle5.

 

[Achille]

Hallo Holger,

von deiner Lösung bin ich sehr beeindruckt. Das ist für mich als Laie schon großes Programmier-Kino. Herzlichen Dank an dich, dass du mir das gezeigt hast.

Zur Info für alle, die es interessiert:

Im Direktbereich liefert für z. Bsp. Tabelle5

debug.print ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Column
10

dasselbe Ergebnis wie

debug.print ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
10

 

[HaHoBe]

Hallo Achille,

Danke für Deine Rückmeldung, aber so groß ist das Kino nicht. Ich habe vesucht, für mich einen Ablaufplan zu schaffen, der die Prüfungen (Eingaben von Tabellennamen, Prüfungen der Tabellen und Anlegen der Übersicht) und die Verfügbarkeit von Kommentaren sicherstellt, bevor es weiterghen soll. Dies ist im Fall Deines Aufbaus sicherlich sinvoll, wenn ich allerdings der Meinung bin, dass das Einfügen der Kommentare auf der Übersichtsseite und das Setzen von Hyperlinks "in einem Rutsch" erledigt werden könnten.

Solltest Du die Prozeduren aber für sich alleine verwenden wollen, dann würde ich ggf. identische Codeteile auslagern (entweder in eine andere Prozedur oder Funktion, wobei ich einer Funktion wegen des Rückgabewertes gegenüber der Prozedur und modulweiten oder globalen Variablen den Vorzug egeben würde). Hintergrund ist eine mögliche Änderung im Code, die Du in Deiner Anwendung an zwei Stellen vornehmen müsstest, wenn sich dort etwas ändern sollte:. Bei meinem Voirgehen ist dies auf eine Stelle reduziert, bei Verwendung einer Funktion kann man entwewder einen booleschen Wert oder eine Zahl zurückliefern und aufgrund des erhaltenen Wertes weiter verfahren.

Hier ist der wohl bekannte Spruch von "Übung macht den Meister" wirklich Programm: je mehr Codes man schreibt, desto eher wird man einen eigenen Weg entwicklen, den Ablauf nach eigenen Vorstellungen umzusetzen. Ich finde es immer spannend, wenn ich im Netz auf vollständig andere Lösungen für das Problem zu stoßen, an die ich zum Zeitpunkt des Entwickeln gar nicht gedacht hatte. Und noch mehr Spaß bringt es dann, wenn diese andere Vorgehensweise auch noch eleganter als die eigene Version ist und man diese erfolgrerich einbauen konnte.

Und man sollte immer "am Ball bleiben", auch wenn ich mich an meine Anfänge zurückerinnere, wo ich manchmal das Gefühl hatte, ich müsste scheitern, weil ich wieder einmal Vorgehensweisen verwechselt hatte.

Da dies ein statisches Beispiel ist, solltest Du Dir ggf. übrlegen, wie Du eine Aktualisierun einbauen könntest. Und wenn ich ganz ehrlich bin, verstehe ich das Einfügen von Hyperlinks auf der Tabelle mit den Kommentaren nicht, denn man könnte von der Übersichtsseite aus zu der jeweils relevanten Zelle zurückkehren.

Viel Spaß noch beim Experimentieren.
Holger