Office: (Office 2016) Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle

Helfe beim Thema Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle in Microsoft Excel Hilfe um das Problem gemeinsam zu lösen; Hallo, es darf kein Blattschutz und/oder Arbeitsmappenschutz aktiv sein. Hat der Name der Quelltabelle ein Leerzeichen ist es für den Ablauf des... Dieses Thema im Forum "Microsoft Excel Hilfe" wurde erstellt von Nael, 22. September 2021.

  1. Nael Neuer User

    Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle


    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:

    Code:
    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
    
    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
    
    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
    
    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
    
    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
    
    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 Sub
    
     
  2. Hajo_Zi
    Hajo_Zi Erfahrener User
    beachte Regeln Punkt 2
    Regeln


    Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle GrußformelKommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle Homepage
     
    1 Person gefällt das.
  3. Exl121150 Erfahrener User
    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))
     
    Exl121150, 23. September 2021
    #3
    1 Person gefällt das.
  4. Nael Neuer User

    Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle

    Im Anhang cell comment hyperlink (korr).xlsm habe ich Hochkomma (Apostroph) hinzugefügt.

    Ich habe jetzt folgende Tests durchgeführt:
    Quelltabelle: Tabelle1, Kommentartabelle: K Tab 1 --> erfolgreich (1243 von 1243 Kommentare)
    Quelltabelle: Tabelle2, Kommentartabelle: K Tab 2 --> erfolgreich (542 von 542 Kommentare
    Quelltabelle: Tabelle3, Kommentartabelle: K Tab 3 --> erfolgreich (12 von 12 Kommentare)
    Quelltabelle: Tabelle4, Kommentartabelle: K Tab 4 --> gescheitert, (nur 1 von 20 Kommentaren wurde verarbeitet), Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle Tab4 unvollständig (1).jpg
    Quelltabelle: Tabelle5, Kommentartabelle: K Tab 5 --> gescheitert, (0 von 9 Kommentaren wurden verarbeitet), Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle Tab5 error (1).jpg , Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle Tab5 error (2).jpg
     
  5. steve1da Super-Moderator
    1 Person gefällt das.
  6. RPP63
    RPP63 Erfahrener User
    … und im Clever-Excel-Forum durfte man ja auch schon die Diskussions"kultur" bewundern …
    Und nein, der Hinweis, dass Excel nicht als Kommentar-Datenbank missbraucht werden sollte, fruchtet nicht.
     
    1 Person gefällt das.
  7. Nael Neuer User
    Hier geht es nicht um den "Missbrauch von Excel als Kommentar-Datenbank", sondern um das Retten der Kommentare aus einer beliebigen Quelltabelle mit Kommentaren in eine neue Kommentartabelle.

    Das sollte der Durchbruch sein:

    ActiveSheet.UsedRange.Columns.Count - 8 what does it mean?
    Gewollt ist, dass alle Kommentare einer beliebigen Quelltabelle in eine neue Kommentartabelle kopiert und in dieser Quelltabelle für alle kopierten Kommentare Hyperlinks auf diese neue Kommentartabelle eingefügt werden.

    Angepasst an das Gewollte, stellen folgende Änderungen eine mögliche Lösung dar:

    In Private Sub Spalteneinfügen_Call()
    Code:
    Dim lastCol1 As Integer
    
    Code:
    With Sheets(wsSourcename)
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastCol1 = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column
        Else
            lastCol1 = 1
        End If
    End With
    
    Code:
    For col1 = lastCol1 To 1 Step -1
    i = 0
    Set myrangeC = Intersect(Columns(col1), _
    Cells.SpecialCells(xlCellTypeComments))
    
    sowie

    in Private Sub PrintCommentsByColumn_alleSpalten_Call()
    Code:
    Dim lastCol As Integer
    
    Code:
    With Sheets(wsSourcename)
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastCol = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column
        Else
            lastCol = 1
        End If
    End With
    
    Code:
    For col = 1 To lastCol
    Set myrangeC = Intersect(Columns(col), _
    Cells.SpecialCells(xlCellTypeComments))
    
     
  8. Exl121150 Erfahrener User

    Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle

    Hallo,

    in der beiliegenden Excel-Datei habe ich die Makros bereinigt und es liefen alle Arbeitsblätter fehlerfrei.
    Wie sinnvoll das Ganze ist, weiß ich nicht - und will es auch nicht beurteilen.
     
    Zuletzt bearbeitet: 27. September 2021
    Exl121150, 27. September 2021
    #8
  9. Nael Neuer User
    Hallo,
    deine beiliegende Excel-Datei mit deinen bereinigten Makros funktioniert nicht.

    Tabelle5 original: Exl121150_cell comment hyperlink (korr).xlsm
    Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle Tabelle5 original.jpg

    Tabelle5 Ergebnis (wie downgeloadet): Nael_cell comment hyperlink (korr).xlsm
    Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle Tabelle5 Ergebnisl.jpg
    Es wurden keine Spalten in Tabelle5 eingefügt. Zelle I23 wird deshalb überschrieben. Die Tabelle5 wird dadurch zerstört.

    Damit die Quelltabellen nicht zerstört werden, sollen mit dem Makro Private Sub Spalteneinfügen_Call Spalten eingefügt werden, in die die Hyperlinks kopiert werden.

    Warum das mit deiner beiliegenden Excel-Datei mit deinen bereinigten Makros nicht funktioniert wird hier erläutert:
    (Office 2016) - Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle
     
  10. Exl121150 Erfahrener User
    Hallo,

    in der Sub Spalteneinfügen_Call() war folgende FOR-Schleifensteuerung enthalten:
    For col1 = wsSource.UsedRange.Columns.Count To 1 Step -1

    Mir ist leider entgangen, dass dies zwangsläufig falsch sein muss, denn verwendet man
    zB. Arbeitsblatt "Tabelle5" als wsSource, so ergibt wsSource.UsedRange den Bereich Tabelle5!$F$1:$J$32, was zu wsSource.UsedRange.Columns.Count=5 führt und somit zu For col1 = 5 To 1 Step -1, was notwendigerweise falsch ist.

    Korrekt muss die FOR-Schleife lauten: For col1 = 6+5-1 To 6 Step -1
    oder in Variablen ausgedrückt:
    For col1 = wsSource.UsedRange.Column+wsSource.UsedRange.Columns.Count-1 To wsSource.UsedRange.Column Step -1
    bzw.
    Code:
    With wsSource
        For col1 = .UsedRange.Column+.UsedRange.Columns.Count-1 To .UsedRange.Column Step -1
    '...
        Next col1
    End With
    
     
    Exl121150, 29. September 2021
    #10
  11. Nael Neuer User
    Hallo,

    herzlichen Dank für deinen Lösungsvorschlag (Nael_cell comment hyperlink (korr1).xlsm), den ich noch durcharbeiten muss. Ich melde mich dazu wieder.

    Deine Code-Bereinigungen muss ich auch noch durch- und in meine Makros einarbeiten.

    Viele Wege führen nach Rom.

    Eine andere Lösung möchte ich hier vorstellen:

    Die nachfolgende Lösung (cell comment hyperlink (2).xlsm) hat den Vorteil, dass auf ActiveSheet.UsedRange.Columns.Count, das für diesen Anwendungsfall nicht ohne Klimmzüge zu einem richtigen Ergebnis führt, verzichtet werden kann und auch keine weitere Funktion Public Function NxtC(Optional ByVal Header As String = "", Optional ByVal Zahl As Integer) As String benötigt wird. Dadurch ist für Laien wie für mich, das Ergebnis insgesamt leichter verständlich.

    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
    
    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
    Dim lastCol1 As Integer '** Änderung gegenüber cell comment hyperlink.xlsm
    
    Worksheets(wsSourcename).Activate
    
    If ActiveSheet.Comments.Count = 0 Then
    MsgBox "Keine Kommentare in der Tabelle"
    Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With Sheets(wsSourcename) '** Änderung gegenüber cell comment hyperlink.xlsm
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastCol1 = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column
        Else
            lastCol1 = 1
        End If
    End With '** Änderung gegenüber cell comment hyperlink.xlsm
    
    For col1 = lastCol1 To 1 Step -1 '** Änderung gegenüber cell comment hyperlink.xlsm
    
    i = 0
    
    Set myrangeC = Intersect(Columns(col1), _
    Cells.SpecialCells(xlCellTypeComments)) '** Änderung gegenüber cell comment hyperlink.xlsm
    
    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
    
    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
    Dim lastCol As Integer '** Änderung gegenüber cell comment hyperlink.xlsm
    
    If ActiveSheet.Comments.Count = 0 Then
    MsgBox "No comments in entire sheet"
    Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With Sheets(wsSourcename) '** Änderung gegenüber cell comment hyperlink.xlsm
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastCol = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column
        Else
            lastCol = 1
        End If
    End With '** Änderung gegenüber cell comment hyperlink.xlsm
    
    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 lastCol '** Änderung gegenüber cell comment hyperlink.xlsm
    
    Set myrangeC = Intersect(Columns(col), _
    Cells.SpecialCells(xlCellTypeComments)) '** Änderung gegenüber cell comment hyperlink.xlsm
    
    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
    
    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
    
    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
    
    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 Sub
    
     
    Zuletzt bearbeitet: 29. September 2021
  12. Nael Neuer User
    Hier bin ich ins Schleudern geraten und habe ich mich geirrt.
    Public Function NxtC(Optional ByVal Header As String = "", Optional ByVal Zahl As Integer) As String ist keine weitere Funktion, sondern ersetzt Public Function NTC(Optional ByVal Header As Variant, Optional ByVal Zahl As Integer) As String.

    Public Function NxtC oder Public Function NTC führen zum selben Ergebnis.

    Verwendung von Public Function NTC (wechselweise auskommentiert)
    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)
       With wsNew
           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
    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
    Verwendung von Public Function NxtC (wechselweise auskommentiert)
    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)
    '   With wsNew
    '       lngZeile = .Range("B" & Rows.Count).End(xlUp).Row
    '       For Each rngZelle In .Range("B3:B" & lngZeile)
    '           rngZelle.Value = NxtC(rngZelle.Value)       'NTC(rngZelle.Value)
    '       Next
    '   End With
    '
    '   Application.Calculation = xlCalculationAutomatic
    '   Application.ScreenUpdating = True
    'End Sub
    Code:
    'Public Function NxtC(Optional ByVal Header As String = "", Optional ByVal Zahl As Integer) As String
    '   NxtC = ""
    '   On Error GoTo Err_NxtC
    '   If Len(Header) Then
    '      NxtC = Range(Header).Offset(0, 1).Address(0, 0)
    '   Else
    '      NxtC = Cells(1, Zahl + 1).Address(0, 0)
    '   End If
    'Err_NxtC:
    'End Function
     
  13. Nael Neuer User

    Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle

    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")
    Aus diesem Grund habe ich das Makro NTC für diese Aufgabenstellung korrigiert:
    Code:
    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
    
     
  14. Nael Neuer User
    Ich habe recherchiert, dass diese Berechnung folgendermaßen zusammengefasst werden kann:

    For col1 = ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Column To 1 Step -1
    bzw.
    For col1 = wsSource.UsedRange.Cells(wsSource.UsedRange.Cells.Count).Column To 1 Step -1

    For col = 1 To ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Column
    bzw.
    For col = 1 To wsSource.UsedRange.Cells(wsSource.UsedRange.Cells.Count).Column
     
  15. Nael Neuer User
    In Private Sub HyperlinkAdresse_Call() ist Dim varEingabe As Variant überflüssig und wurde gelöscht.
     
Thema:

Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle

Die Seite wird geladen...
  1. Kommentare in neue Kommentartabelle kopieren, Quelltabelle: Hyperlinks auf die Kommentartabelle - Similar Threads - Kommentare Kommentartabelle kopieren

  2. Kommentare löschen wenn Zelle leer

    in Microsoft Excel Hilfe
    Kommentare löschen wenn Zelle leer: Guten Tag zusammen. Ich stehe vor folgendem Problem. Mit dem Makro: Private Sub Worksheet_Change(ByVal Target As Range) Target.NoteText "Am " & Format(Date, "dd.mm.yy") & " um " & Format(Now(),...
  3. Kommentar durchgestrichen

    in Microsoft Excel Hilfe
    Kommentar durchgestrichen: Hallo, ich erstelle Kommentar per VBA in mehreren Zellen. ThisWorkbook.Worksheets("Preisseite BMS").cells(10,3) .Comment.Text Text:=.Comment.Text & Cells(loi,5) & Chr(10)...
  4. Druckoption mit Kommentare

    in Microsoft Teams Hilfe
    Druckoption mit Kommentare: Frage: Bei Word 2013 ist in der Druckoption der Rand der Kommentarleiste grau unterlegt. Wie kann ich dieses ausblenden?[GW1] Vielleicht hat jemand eine Idee und kann mir bitte helfen. MfG...
  5. Benachrichtigung innerhalb eines Kanals, wenn ein Kommentar o.ä. erstellt wird...

    in Microsoft Teams Hilfe
    Benachrichtigung innerhalb eines Kanals, wenn ein Kommentar o.ä. erstellt wird...: Wie kann ich in MS-Teams sicherstellen, dass alle Mitarbeiter eines Kanals eine Benachrichtigung erhalten, wenn ich "Kommentare" erstelle, Aufgaben verteile oder oder. AFAIK geht das nur, wenn die...
  6. In einzelnen Teams keine Benachrichtigung bei Kommentaren

    in Microsoft Teams Hilfe
    In einzelnen Teams keine Benachrichtigung bei Kommentaren: Wenn ich bei einer Aufgabe ein Kommentar hinterlasse dann bekommen in einigen Teams, die der Aufgabe zugewiesenen Personen eine Benachrichtigung per E-Mail. In einigen Teams funktioniert dies...
  7. Planner - Benachrichtigungen zu Kommentaren an bestimmte Personen

    in Microsoft Teams Hilfe
    Planner - Benachrichtigungen zu Kommentaren an bestimmte Personen: Ich habe eine Frage zum Planner ... wenn ich eine Aufgabe mehreren Usern zugeordnet ist und ich einen Kommentar eingebe, dann wird die Benachrichtigung an alle zugeordnete User ausgegeben. Ist es...
  8. Kommentar hinzufügen funktioniert nicht

    in Microsoft PowerPoint Hilfe
    Kommentar hinzufügen funktioniert nicht: Hallo liebes Hilfe-Forum, ich habe folgendes Problem mit meiner PowerPoint-Präsentation: Ich möchte Kommentare zu meinen Folien hinzufügen. Wenn ich auf das hierfür vorgesehene Feld klicke,...
Schlagworte:
  1. Diese Seite verwendet Cookies, um Inhalte zu personalisieren, diese deiner Erfahrung anzupassen und dich nach der Registrierung angemeldet zu halten.
    Auf dieser Website werden Cookies für die Zugriffsanalyse und Anzeigenmessung verwendet.
    Wenn du dich weiterhin auf dieser Seite aufhältst, akzeptierst du unseren Einsatz von Cookies.
    Information ausblenden