Zellenkommentare aus Quelltabelle in neue Kommentartabelle speichern, neue Hyperlinks in Quelltabelle auf Kommentare in Kommentartabelle

  • Excel

Es gibt 1 Antwort in diesem Thema. Der letzte Beitrag () ist von Zoe4711.

    Zellenkommentare aus Quelltabelle in neue Kommentartabelle speichern, neue Hyperlinks in Quelltabelle auf Kommentare in Kommentartabelle

    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.

    Visual Basic-Quellcode

    1. Option Explicit
    2. Private wsSource As Worksheet
    3. Private wsNew As Worksheet
    4. Private wsSourcename As Variant
    5. Private wsNewname As Variant
    7. Sub Zelle_Kommentar_neueSpalte_Hyperlink()
    8. Dim varEingabewsSource As Variant
    9. Dim varEingabewsNew As Variant
    10. varEingabewsSource = InputBox("Name der Quelltabelle?")
    11. varEingabewsNew = InputBox("Name der Kommentartabelle?")
    12. wsSourcename = varEingabewsSource
    13. wsNewname = varEingabewsNew
    14. Call Spalteneinfügen_Call
    15. Call PrintCommentsByColumn_alleSpalten_Call
    16. Call HyperlinkAdresse_Call
    17. Call HyperlinkaufandereTabelleeinfügen_Call
    18. End Sub


    Visual Basic-Quellcode

    1. Private Sub Spalteneinfügen_Call()
    2. Dim cell As Range
    3. Dim myrange As Range, myrangeC As Range
    4. Dim col1 As Long
    5. Dim i As Long
    6. Dim j As Long
    7. Application.ScreenUpdating = False
    8. Application.Calculation = xlCalculationManual
    9. Worksheets(wsSourcename).Activate
    10. If ActiveSheet.Comments.Count = 0 Then
    11. MsgBox "Keine Kommentare in der Tabelle"
    12. Exit Sub
    13. End If
    14. For col1 = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
    15. i = 0
    16. Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col1), _
    17. Cells.SpecialCells(xlCellTypeComments))
    18. If myrangeC Is Nothing Then GoTo nxtCol ' Keine Kommentare in einer Spalte --> nächste Spalte
    19. For Each cell In myrangeC
    20. On Error GoTo LabelC
    21. If Trim(cell.Comment.Text) <> "" Then ' Zelle mit Kommentar
    22. i = i + 1
    23. ' Sobald in einer Spalte die erste Zelle mit Kommentar (i = 1) ermittelt wurde,
    24. ' selektiere die Zelle in der Spalte rechts davon und füge eine Spalte ein.
    25. If i = 1 Then
    26. Range(cell.Address(0, 0)).Select
    27. ActiveCell.Offset(0, i).Select
    28. ActiveCell.EntireColumn.Insert
    29. Else: GoTo nxtCol ' Es wird nach jeder Spalte mit Kommentar nur eine leere Spalte eingefügt.
    30. End If
    31. End If
    33. LabelB:
    34. On Error GoTo 0 ' error handling aktivieren
    35. Next cell
    37. nxtCol:
    38. On Error GoTo 0 ' error handling aktivieren
    39. Next col1
    41. LabelC:
    42. If col1 = 0 Then GoTo LabelD
    43. j = j + 1
    44. If j = 1 And Err > 0 Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
    45. If Err > 0 Then Debug.Print " "; j, " "; cell.MergeArea.Address, " "; Err.Number, ""; Err.Description
    46. Resume LabelB
    48. LabelD:
    49. Application.Calculation = xlCalculationAutomatic
    50. Application.ScreenUpdating = True
    51. On Error GoTo 0 ' error handling aktivieren
    52. End Sub


    Visual Basic-Quellcode

    1. Private Sub PrintCommentsByColumn_alleSpalten_Call()
    2. Dim cell As Range
    3. Dim myrange As Range, myrangeC As Range
    4. Dim col As Long
    5. Dim RowOS As Long
    6. Dim j As Long
    7. If ActiveSheet.Comments.Count = 0 Then
    8. MsgBox "No comments in entire sheet"
    9. Exit Sub
    10. End If
    11. Application.ScreenUpdating = False
    12. Application.Calculation = xlCalculationManual
    13. Set wsSource = Worksheets(wsSourcename)
    14. Set wsSource = ActiveSheet
    15. Sheets.Add
    16. Set wsNew = ActiveSheet
    17. ActiveSheet.Name = wsNewname
    18. wsSource.Activate
    19. With wsNew.Columns("A:E")
    20. .VerticalAlignment = xlTop
    21. .WrapText = True
    22. End With
    23. wsNew.Columns("A").ColumnWidth = 10
    24. wsNew.Columns("B").ColumnWidth = 10
    25. wsNew.Columns("C").ColumnWidth = 15
    26. wsNew.Columns("D").ColumnWidth = 60
    27. wsNew.PageSetup.PrintGridlines = True
    28. RowOS = 2
    29. wsNew.Cells(1, 1) = "Adresse1"
    30. wsNew.Cells(1, 1).Font.Bold = True
    31. wsNew.Cells(1, 2) = "Adresse2"
    32. wsNew.Cells(1, 2).Font.Bold = True
    33. wsNew.Cells(1, 3) = "Zellwert"
    34. wsNew.Cells(1, 3).Font.Bold = True
    35. wsNew.Cells(1, 4) = "Kommentar"
    36. wsNew.Cells(1, 4).Font.Bold = True
    37. For col = 1 To ActiveSheet.UsedRange.Columns.Count
    38. Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col), _
    39. Cells.SpecialCells(xlCellTypeComments))
    40. If myrangeC Is Nothing Then GoTo nxtCol
    41. For Each cell In myrangeC
    42. On Error GoTo LabelC
    43. If Trim(cell.Comment.Text) <> "" Then
    44. RowOS = RowOS + 1
    45. wsNew.Cells(RowOS, 1) = "A" & RowOS
    46. wsNew.Cells(RowOS, 2) = cell.Address(0, 0)
    47. wsNew.Cells(RowOS, 3) = cell.Text
    48. wsNew.Cells(RowOS, 4) = cell.Comment.Text
    49. End If
    51. LabelB:
    52. On Error GoTo 0 ' error handling aktivieren
    53. Next cell
    55. nxtCol:
    56. On Error GoTo 0 ' error handling aktivieren
    57. Next col
    59. LabelC:
    60. If col > ActiveSheet.UsedRange.Columns.Count Then GoTo LabelD
    61. j = j + 1
    62. If j = 1 And cell.MergeCells = True Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
    63. If Err > 0 Then Debug.Print " "; j, " "; cell.MergeArea.Address, " "; Err.Number, ""; Err.Description
    64. Resume LabelB
    66. LabelD:
    67. wsNew.Activate
    68. Application.Calculation = xlCalculationAutomatic
    69. Application.ScreenUpdating = True
    70. On Error GoTo 0 ' error handling aktivieren
    71. End Sub


    Visual Basic-Quellcode

    1. Private Sub HyperlinkAdresse_Call()
    2. Dim rngZelle As Range
    3. Dim lngZeile As Long
    4. Dim varEingabe As Variant
    5. Application.ScreenUpdating = False
    6. Application.Calculation = xlCalculationManual
    7. Set wsNew = Worksheets(wsNewname)
    8. Set wsNew = ActiveSheet
    9. With ActiveSheet
    10. lngZeile = .Range("B" & Rows.Count).End(xlUp).Row
    11. For Each rngZelle In .Range("B3:B" & lngZeile)
    12. rngZelle.Value = NTC(rngZelle.Value)
    13. Next
    14. End With
    15. Application.Calculation = xlCalculationAutomatic
    16. Application.ScreenUpdating = True
    17. End Sub


    Visual Basic-Quellcode

    1. Public Function NTC(Optional ByVal Header As Variant, Optional ByVal Zahl As Integer) As String
    2. Dim i As Integer
    4. If Header = "" Then GoTo Weiter
    5. Zahl = Range(Range(Header & "1").Address).Column + 1
    7. Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
    8. If Zahl <= 0 Or Zahl > 16384 Then Exit Function
    9. NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0) & Range(Range(Header).Address).Row
    10. End Function


    Visual Basic-Quellcode

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

    Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „Zoe4711“ () aus folgendem Grund: redaktionelle Änderung

    "Exl121150" schrieb:


    office-hilfe.com/support/threa…abelle.55185/#post-329154
    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))



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

    Visual Basic-Quellcode

    1. Function NTC(Optional ByVal Header As String, Optional ByVal Zahl As Integer) As String
    2. Dim I As Integer
    3. Dim acol As Long
    4. Dim Bereich As Range, RNG As Range
    6. If Header = "" Then GoTo Weiter
    7. acol = Cells(1, Columns.Count).End(xlToLeft).Column
    8. Set Bereich = Range(Range("A1"), Cells(1, acol))
    9. Set RNG = Bereich.Find(What:=Header, LookIn:=xlValues, LookAt:=xlWhole)
    10. If Not RNG Is Nothing Then
    11. Zahl = Range(RNG.Address).Column
    12. End If
    14. Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
    15. If Zahl <= 0 Or Zahl > 16384 Then Exit Function
    16. NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0)
    17. End Function


    Visual Basic-Quellcode

    1. Sub Hohls()
    2. MsgBox NTC(Header:="DeinHeader")
    3. MsgBox NTC(Zahl:=16384)
    4. End Sub



    Es wird dann beide male die Spaltenbezeichnung zurückgegeben.



    Aus diesem Grund habe ich das Makro NTC für diese Aufgabenstellung korrigiert:

    Visual Basic-Quellcode

    1. Public Function NTC(Zellenwert As String) As String
    2. Dim i As Integer
    3. Dim Zahl As Integer
    5. If Zellenwert = "" Then GoTo Weiter
    6. Zahl = Range(Range(Zellenwert & "1").Address).Column + 1
    8. Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
    9. If Zahl <= 0 Or Zahl > 16384 Then Exit Function
    10. NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0) & Range(Range(Zellenwert).Address).Row
    11. End Function


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

    Und komplett:

    Visual Basic-Quellcode

    1. Option Explicit
    2. Private wsSource As Worksheet
    3. Private wsNew As Worksheet
    4. Private wsSourcename As Variant
    5. Private wsNewname As Variant
    7. Sub Zelle_Kommentar_neueSpalte_Hyperlink()
    8. Dim varEingabewsSource As Variant
    9. Dim varEingabewsNew As Variant
    10. varEingabewsSource = InputBox("Name der Quelltabelle?")
    11. varEingabewsNew = InputBox("Name der Kommentartabelle?")
    12. wsSourcename = varEingabewsSource
    13. wsNewname = varEingabewsNew
    14. Call Spalteneinfügen_Call
    15. Call PrintCommentsByColumn_alleSpalten_Call
    16. Call HyperlinkAdresse_Call
    17. Call HyperlinkaufandereTabelleeinfügen_Call
    18. End Sub


    Visual Basic-Quellcode

    1. Private Sub Spalteneinfügen_Call()
    2. Dim cell As Range
    3. Dim myrange As Range, myrangeC As Range
    4. Dim col1 As Long
    5. Dim i As Long
    6. Dim j As Long
    7. Application.ScreenUpdating = False
    8. Application.Calculation = xlCalculationManual
    9. Worksheets(wsSourcename).Activate
    10. If ActiveSheet.Comments.Count = 0 Then
    11. MsgBox "Keine Kommentare in der Tabelle"
    12. Exit Sub
    13. End If
    14. For col1 = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
    15. i = 0
    16. Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col1), _
    17. Cells.SpecialCells(xlCellTypeComments))
    18. If myrangeC Is Nothing Then GoTo nxtCol ' Keine Kommentare in einer Spalte --> nächste Spalte
    19. For Each cell In myrangeC
    20. On Error GoTo LabelC
    21. If Trim(cell.Comment.Text) <> "" Then ' Zelle mit Kommentar
    22. i = i + 1
    23. ' Sobald in einer Spalte die erste Zelle mit Kommentar (i = 1) ermittelt wurde,
    24. ' selektiere die Zelle in der Spalte rechts davon und füge eine Spalte ein.
    25. If i = 1 Then
    26. Range(cell.Address(0, 0)).Select
    27. ActiveCell.Offset(0, i).Select
    28. ActiveCell.EntireColumn.Insert
    29. Else: GoTo nxtCol ' Es wird nach jeder Spalte mit Kommentar nur eine leere Spalte eingefügt.
    30. End If
    31. End If
    33. LabelB:
    34. On Error GoTo 0 ' error handling aktivieren
    35. Next cell
    37. nxtCol:
    38. On Error GoTo 0 ' error handling aktivieren
    39. Next col1
    41. LabelC:
    42. If col1 = 0 Then GoTo LabelD
    43. j = j + 1
    44. If j = 1 And Err > 0 Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
    45. If Err > 0 Then Debug.Print " "; j, " "; cell.MergeArea.Address, " "; Err.Number, ""; Err.Description
    46. Resume LabelB
    48. LabelD:
    49. Application.Calculation = xlCalculationAutomatic
    50. Application.ScreenUpdating = True
    51. On Error GoTo 0 ' error handling aktivieren
    52. End Sub


    Visual Basic-Quellcode

    1. Private Sub PrintCommentsByColumn_alleSpalten_Call()
    2. Dim cell As Range
    3. Dim myrange As Range, myrangeC As Range
    4. Dim col As Long
    5. Dim RowOS As Long
    6. Dim j As Long
    7. If ActiveSheet.Comments.Count = 0 Then
    8. MsgBox "No comments in entire sheet"
    9. Exit Sub
    10. End If
    11. Application.ScreenUpdating = False
    12. Application.Calculation = xlCalculationManual
    13. Set wsSource = Worksheets(wsSourcename)
    14. Set wsSource = ActiveSheet
    15. Sheets.Add
    16. Set wsNew = ActiveSheet
    17. ActiveSheet.Name = wsNewname
    18. wsSource.Activate
    19. With wsNew.Columns("A:E")
    20. .VerticalAlignment = xlTop
    21. .WrapText = True
    22. End With
    23. wsNew.Columns("A").ColumnWidth = 10
    24. wsNew.Columns("B").ColumnWidth = 10
    25. wsNew.Columns("C").ColumnWidth = 15
    26. wsNew.Columns("D").ColumnWidth = 60
    27. wsNew.PageSetup.PrintGridlines = True
    28. RowOS = 2
    29. wsNew.Cells(1, 1) = "Adresse1"
    30. wsNew.Cells(1, 1).Font.Bold = True
    31. wsNew.Cells(1, 2) = "Adresse2"
    32. wsNew.Cells(1, 2).Font.Bold = True
    33. wsNew.Cells(1, 3) = "Zellwert"
    34. wsNew.Cells(1, 3).Font.Bold = True
    35. wsNew.Cells(1, 4) = "Kommentar"
    36. wsNew.Cells(1, 4).Font.Bold = True
    37. For col = 1 To ActiveSheet.UsedRange.Columns.Count
    38. Set myrangeC = Intersect(ActiveSheet.UsedRange, Columns(col), _
    39. Cells.SpecialCells(xlCellTypeComments))
    40. If myrangeC Is Nothing Then GoTo nxtCol
    41. For Each cell In myrangeC
    42. On Error GoTo LabelC
    43. If Trim(cell.Comment.Text) <> "" Then
    44. RowOS = RowOS + 1
    45. wsNew.Cells(RowOS, 1) = "A" & RowOS
    46. wsNew.Cells(RowOS, 2) = cell.Address(0, 0)
    47. wsNew.Cells(RowOS, 3) = cell.Text
    48. wsNew.Cells(RowOS, 4) = cell.Comment.Text
    49. End If
    51. LabelB:
    52. On Error GoTo 0 ' error handling aktivieren
    53. Next cell
    55. nxtCol:
    56. On Error GoTo 0 ' error handling aktivieren
    57. Next col
    59. LabelC:
    60. If col > ActiveSheet.UsedRange.Columns.Count Then GoTo LabelD
    61. j = j + 1
    62. If j = 1 And cell.MergeCells = True Then Debug.Print "Anzahl Zellen", "Addressbereich Verbundene Zellen", "Error Nummer", "Error Beschreibung"
    63. If Err > 0 Then Debug.Print " "; j, " "; cell.MergeArea.Address, " "; Err.Number, ""; Err.Description
    64. Resume LabelB
    66. LabelD:
    67. wsNew.Activate
    68. Application.Calculation = xlCalculationAutomatic
    69. Application.ScreenUpdating = True
    70. On Error GoTo 0 ' error handling aktivieren
    71. End Sub


    Visual Basic-Quellcode

    1. Private Sub HyperlinkAdresse_Call()
    2. Dim rngZelle As Range
    3. Dim lngZeile As Long
    4. Application.ScreenUpdating = False
    5. Application.Calculation = xlCalculationManual
    6. Set wsNew = Worksheets(wsNewname)
    7. Set wsNew = ActiveSheet
    8. With ActiveSheet
    9. lngZeile = .Range("B" & Rows.Count).End(xlUp).Row
    10. For Each rngZelle In .Range("B3:B" & lngZeile)
    11. rngZelle.Value = NTC(rngZelle.Value)
    12. Next
    13. End With
    14. Application.Calculation = xlCalculationAutomatic
    15. Application.ScreenUpdating = True
    16. End Sub


    Visual Basic-Quellcode

    1. Public Function NTC(Zellenwert As String) As String
    2. Dim i As Integer
    3. Dim Zahl As Integer
    5. If Zellenwert = "" Then GoTo Weiter
    6. Zahl = Range(Range(Zellenwert & "1").Address).Column + 1
    8. Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
    9. If Zahl <= 0 Or Zahl > 16384 Then Exit Function
    10. NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0) & Range(Range(Zellenwert).Address).Row
    11. End Function


    Visual Basic-Quellcode

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

Facebook
Telefonspende