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:
cell comment hyperlink.xlsm
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:
VBA 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
VBA 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
VBA 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
VBA 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
VBA 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
VBA 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 Subcell comment hyperlink.xlsm
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.
