Copy Comments to new comment sheet, create hyperlinks in source sheet to comment sheet

A

Achille

New Member
Joined
Aug 25, 2021
Messages
13
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
Hello,

sheets and/or workbook shall not be protected.

If the name of the source sheet consists of blanks this is no problem for the running of the macro, but the name of the new comment sheet shall not consist of blanks and shall not be too long.

The macro asks for the name of the source table, the name of the new comment table, copies the comments from the source table to the comment table, inserts columns into the source table and pastes hyperlinks to the comment sheet in the cells of these columns in the source sheet:

VBA 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

VBA 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


VBA 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

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

cell comment hyperlink.xlsm
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
An error explanation and a remedy:

ActiveSheet.UsedRange.Columns.Count - 8 what does it mean?

ActiveSheet.UsedRange.select

Seems like you want to move around. Try this:

ActiveSheet.UsedRange.select
results in....

xQ0ut.png

If you want to move that selection 3 rows up then try this

ActiveSheet.UsedRange.offset(-3).select
does this...

Qugcd.png
Click to expand...

To find the last column which has data, use .Find

BernardSaucier has already given you an answer. My post is not an answer but an explanation as to why you shouldn't be using `UsedRange`.

`UsedRange` is highly unreliable as shown HERE

To find the last column which has data, use `.Find` and then subtract from it.
Code: 
With Sheets("Sheet1")
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
If lastCol > 8 Then
'Debug.Print ActiveSheet.UsedRange.Columns.Count - 8
'The above becomes
Debug.Print lastCol - 8
End If
Click to expand...

The macro shall work with each source sheet. The macro asks for the name of the source sheet, the name of the new comment sheet, copies the comments from the source sheet to the comment sheet, inserts columns into the source sheet and pastes hyperlinks to the comment sheet in the cells of these columns in the source sheet:

The following changes show a possible solution:

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

as well as

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))
 
Upvote 0
This is a possible solution. Of course there is a lot code optimization possible and necessary, but it works.

The macro works with any source sheet. The macro asks for the name of the source sheet, the name of the new comment sheet, copies the comments from the source sheet to the comment sheet, inserts columns into the source sheet and pastes hyperlinks to the comment sheet in the cells of these columns in the source sheet.

VBA 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?") '** Name der Quelltabelle? means name of the source sheet?
varEingabewsNew = InputBox("Name der Kommentartabelle?") '** Name der Kommentartabelle? means name of the comment sheet?
wsSourcename = varEingabewsSource
wsNewname = varEingabewsNew
Call Spalteneinfügen_Call '** Spalten einfügen means insert columns
Call PrintCommentsByColumn_alleSpalten_Call '** alle Spalten means every column
Call HyperlinkAdresse_Call '** Hyperlink Adresse means hyperlink address
Call HyperlinkaufandereTabelleeinfügen_Call '** Hyperlink auf andere Tabelle einfügen means Insert hyperlink to other sheet
End Sub

VBA Code: 
Private Sub Spalteneinfügen_Call() '** Spalten einfügen means insert columns
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 '** change compared with 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) '** change compared with 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 '** change compared with cell comment hyperlink.xlsm

For col1 = lastCol1 To 1 Step -1 '** change compared with cell comment hyperlink.xlsm

i = 0

Set myrangeC = Intersect(Columns(col1), _
Cells.SpecialCells(xlCellTypeComments)) '** change compared with cell comment hyperlink.xlsm

If myrangeC Is Nothing Then GoTo nxtCol ' no comments in a column --> next column
For Each cell In myrangeC
On Error GoTo LabelC
If Trim(cell.Comment.Text) <> "" Then ' ** cell with comment
i = i + 1
'** As soon as the first cell with comment is found (i = 1),
'** select the cell in the column to the right side and insert a column.
If i = 1 Then
Range(cell.Address(0, 0)).Select
ActiveCell.Offset(0, i).Select
ActiveCell.EntireColumn.Insert
Else: GoTo nxtCol '** After each column with comments only one empty column for the hyperlinks is inserted.
End If
End If

LabelB:
On Error GoTo 0 '** error handling activated
Next cell

nxtCol:
On Error GoTo 0 '** error handling activated
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

'** Anzahl Zellen means amount of cells
'** Adressbereich Verbundene Zellen means address of merged area

LabelD:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0 '** error handling activated
End Sub

VBA Code: 
Private Sub PrintCommentsByColumn_alleSpalten_Call() '** alle Spalten means every column
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 '** change compared with 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) '** change compared with 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 '** change compared with 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 '** change compared with cell comment hyperlink.xlsm

Set myrangeC = Intersect(Columns(col), _
Cells.SpecialCells(xlCellTypeComments)) '** change compared with 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 activated
Next cell

nxtCol:
On Error GoTo 0 '** error handling activated
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

'** Anzahl Zellen means amount of cells
'** Adressbereich Verbundene Zellen means address of merged area

LabelD:
wsNew.Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0 '** error handling activated
End Sub

VBA Code: 
Private Sub HyperlinkAdresse_Call() '** Hyperlink Adresse means hyperlink address
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

VBA 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

VBA Code: 
Private Sub HyperlinkaufandereTabelleeinfügen_Call() '** Hyperlink auf andere Tabelle einfügen means Insert hyperlink to other sheet
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

cell comment hyperlink (2).xlsm
 
Upvote 0
Achille said:
Public Function NTC(Optional ByVal Header As Variant, Optional ByVal Zahl As Integer) As String
Click to expand...
"Public Function NTC(Optional ByVal Header As Variant, Optional ByVal Zahl As Integer) As String" needs an improvement.

The original code of "Public Function NTC(Optional ByVal Header As Variant, Optional ByVal Zahl As Integer) As String" originates from a solution for another task at http_www_office-loesung_de/ftopic634022_0_0_asc.php.

In this original solution the variable "Header" ("column label") and the variable "Zahl" ("number") have an importance, because for both variables the result is the column heading.
VBA 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

VBA Code: 
Sub Hohls()
MsgBox NTC(Header:="DeinHeader")
MsgBox NTC(Zahl:=16384)
End Sub

Es wird dann beide male die Spaltenbezeichnung zurückgegeben. (Both times the result ist the column heading.)
Click to expand...


For this task "Copy Comments to new comment sheet, create hyperlinks in source sheet to comment sheet" the variable "Zahl" ("number") is not needed and the variable "Header" is the wrong name.

Improved it looks like this:
VBA Code: 
Public Function NTC(CellValue as String) As String
Dim i As Integer
Dim number As Integer

If CellValue = "" Then GoTo Further
number = Range(Range(CellValue & "1").Address).Column + 1

Further: '*** Z = 26, ZZ = 702, XFD = 16384 ***
If number <= 0 Or Zahl > 16384 Then Exit Function
NTC = Split(Cells(1, number).Address(, 0), "$")(0) & Range(Range(CellValue).Address).Row
End Function

And complete:

This is a possible solution. Of course there is a lot code optimization possible and necessary, but it works.

The macro works with any source sheet. The macro asks for the name of the source sheet, the name of the new comment sheet, copies the comments from the source sheet to the comment sheet, inserts columns into the source sheet and pastes hyperlinks to the comment sheet in the cells of these columns in the source sheet.
VBA Code: 
Option Explicit

Private wsSource As Worksheet
Private wsNew As Worksheet
Private SourceSheetName As Variant
Private NewSheetName As Variant

Sub Cell_Comment_NewColumn_Hyperlink()
Dim var_Input_SourceSheetName As Variant
Dim var_Input_NewSheetName As Variant
var_Input_SourceSheetName = InputBox("name of the source sheet?")
var_Input_NewSheetName = InputBox("name of the comment sheet?")
SourceSheetName = var_Input_SourceSheetName
NewSheetName = var_Input_NewSheetName
Call InsertColumn_Call
Call PrintCommentsByColumn_AllColumns_Call
Call HyperlinkAddress_Call
Call HyperlinkFromSourceSheetToNewSheet_Call
End Sub

VBA Code: 
Private Sub InsertColumn_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(SourceSheetName).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(SourceSheetName)
    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 ' no comments in a column --> next column
For Each cell In myrangeC
On Error GoTo LabelC
If Trim(cell.Comment.Text) <> "" Then ' ** cell with comment
i = i + 1
'** As soon as the first cell with comment is found (i = 1),
'** select the cell in the column to the right side and insert a column.
If i = 1 Then
Range(cell.Address(0, 0)).Select
ActiveCell.Offset(0, i).Select
ActiveCell.EntireColumn.Insert
Else: GoTo nxtCol '** After each column with comments only one empty column for the hyperlinks is inserted.
End If
End If

LabelB:
On Error GoTo 0 '** error handling activated
Next cell

nxtCol:
On Error GoTo 0 '** error handling activated
Next col1

LabelC:
If col1 = 0 Then GoTo LabelD
j = j + 1
If j = 1 And Err > 0 Then Debug.Print "amount of cells", "address of merged area", "Error Number", "Error Description"
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 activated
End Sub

VBA 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(SourceSheetName)
Set wsSource = ActiveSheet
Sheets.Add
Set wsNew = ActiveSheet
ActiveSheet.Name = NewSheetName
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 "amount of cells", "address of merged area", "Error Number", "Error Description"
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

VBA Code: 
Private Sub PrintCommentsByColumn_AllColumns_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(SourceSheetName)
    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(SourceSheetName)
Set wsSource = ActiveSheet
Sheets.Add
Set wsNew = ActiveSheet
ActiveSheet.Name = NewSheetName
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 activated
Next cell

nxtCol:
On Error GoTo 0 '** error handling activated
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 "amount of cells", "address of merged area", "Error Number", "Error Description"
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 activated
End Sub

VBA Code: 
Private Sub HyperlinkAddress_Call()
Dim rngZelle As Range
Dim lngZeile As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsNew = Worksheets(NewSheetName)
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

VBA Code: 
Public Function NTC(CellValue as String) As String
Dim i As Integer
Dim number As Integer

If CellValue = "" Then GoTo Further
number = Range(Range(CellValue & "1").Address).Column + 1

Further: '*** Z = 26, ZZ = 702, XFD = 16384 ***
If number <= 0 Or number > 16384 Then Exit Function
NTC = Split(Cells(1, number).Address(, 0), "$")(0) & Range(Range(CellValue).Address).Row
End Function

VBA Code: 
Private Sub HyperlinkFromSourceSheetToNewSheet_Call()
Dim lngZeile As Long
Worksheets(SourceSheetName).Activate
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    With ActiveWorkbook.Worksheets(NewSheetName)
        For lngZeile = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
            Range(CStr(Sheets(NewSheetName).Cells(lngZeile, 2))).Select
           ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & NewSheetName & "'!" & CStr(Sheets(NewSheetName).Cells(lngZeile, 1)) _
            , TextToDisplay:=CStr(Sheets(NewSheetName).Cells(lngZeile, 1))
        Next
    End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

cell comment hyperlink (3).xlsm
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Macro: Copy/rename sheet and create hyperlink. Error. Are shared documents not macro friendly?
Replies
1
Views
197
Micron
M
Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
347
Agnarr
Agnarr
R
  • Question
VBA to Copy Multiple sheets to new workbook & save as .xlsb or .xlsx
2
Replies
16
Views
701
rahildhody
R
J
  • Question
VBA Copying each cell that has a hyperlink in a row each to a new sheet, which has data from a Master template sheet
2
Replies
10
Views
927
Alex Blakenburg
A
A
  • Question
Copy columns from existing sheet to new sheet with VBA
Replies
3
Views
3K
Fluff
Fluff

Forum statistics

Threads
1,214,975
Messages
6,122,537
Members
449,088
Latest member
RandomExceller01

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top