Hallo,
Verbesserungsvorschläge für dieses Projekt sind herzlich willkommen.
Diese Makros fragen 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:
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. Den Grund dafür kenne ich nicht.
Diese Makros kommen in ein Modul, z. Bsp.: Modul1. Datei cell comment hyperlink.xlsx speichern als cell comment hyperlink.xlsm und Makros in Modul1 einfügen.
Verbesserungsvorschläge für dieses Projekt sind herzlich willkommen.
Diese Makros fragen 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:
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. Den Grund dafür kenne ich nicht.
Diese Makros kommen in ein Modul, z. Bsp.: Modul1. Datei cell comment hyperlink.xlsx speichern als cell comment hyperlink.xlsm und Makros in Modul1 einfügen.
Visual Basic-Quellcode
- 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
Visual Basic-Quellcode
- 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
Visual Basic-Quellcode
- 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
Visual Basic-Quellcode
- 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
Visual Basic-Quellcode
- 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
Visual Basic-Quellcode
- 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
Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „Zoe4711“ () aus folgendem Grund: redaktionelle Änderung