Office: (Office 2016) 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

 

beachte Regeln Punkt 2
Regeln

 

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

 

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),
Quelltabelle: Tabelle5, Kommentartabelle: K Tab 5 --> gescheitert, (0 von 9 Kommentaren wurden verarbeitet), ,

 

Kommentare in neue Kommentartabelle

Dort würde man sich bestimmt auch über Feedback freuen....

 

… 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.

 

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

 

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.

 

Hallo,
deine beiliegende Excel-Datei mit deinen bereinigten Makros funktioniert nicht.

Tabelle5 original: Exl121150_cell comment hyperlink (korr).xlsm


Tabelle5 Ergebnis (wie downgeloadet): Nael_cell comment hyperlink (korr).xlsm

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

 

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

 

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

 

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

 

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

 

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

 

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