Kommentare in neue Kommentartabelle kopieren, in der Quelltabelle einfügen von Hyperlinks auf die Kommentare in der Kommentartabelle
Hallo,
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")
Zitat:Code:
Function NTC(Optional ByVal Header As String, Optional ByVal Zahl As Integer) As String
Dim I As Integer
Dim acol As Long
Dim Bereich As Range, RNG As Range
If Header = "" Then GoTo Weiter
acol = Cells(1, Columns.Count).End(xlToLeft).Column
Set Bereich = Range(Range("A1"), Cells(1, acol))
Set RNG = Bereich.Find(What:=Header, LookIn:=xlValues, LookAt:=xlWhole)
If Not RNG Is Nothing Then
Zahl = Range(RNG.Address).Column
End If
Weiter: '*** Z = 26, ZZ = 702, XFD = 16384 ***
If Zahl <= 0 Or Zahl > 16384 Then Exit Function
NTC = Split(Cells(1, Zahl).Address(, 0), "$")(0)
End Function
Code:
Sub Hohls()
MsgBox NTC(Header:="DeinHeader")
MsgBox NTC(Zahl:=16384)
End Sub
Es wird dann beide male die Spaltenbezeichnung zurückgegeben.
Aus diesem Grund habe ich die Private Function 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
Das
dort erklärte, habe ich auch noch korrigiert.
Tutti completti:
Es sind selbstverständlich noch Code-Optimierungen möglich und nöitg, aber das Grundgerüst steht und funktioiniert jetzt. Alle Kommentare einer beliebigen Quelltabelle werden in eine neue Kommentartabelle kopiert und in der Quelltabelle für alle Kommentare Hyperlinks auf die Kommentartabelle eingefügt.
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
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)
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
For col1 = lastCol1 To 1 Step -1
i = 0
Set myrangeC = Intersect(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
Dim lastCol As Integer
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)
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
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
Set myrangeC = Intersect(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(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
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
[
attachment=40468]