A week of struggling to covert an ActiveSheet.comments collection into a 2D array

Shmerty

New Member
Joined
Oct 30, 2013
Messages
36
Afternoon everyone,

I'll try and keep this short and unambiguous. I have a spreadsheet with pupils names (rows) and the subjects (columns) they are struggling in (I'm a teacher). The final column counts the number of notes for each pupil (row). I did manage to write a quick subroutine that counted the comments across that row, but when the SS became 90 rows, the SS started the lag badly (the subroutine was called from within each cell in the final column =countNotes(range). So I started rewriting the subroutine so that it uses the ActiveSheet.comments collection to populate the last column when SS opens and when user saves it. But I'm struggling and wise enough to know I need help.

Here's a visual representation of what I'm trying to do:
Code:
'                                                                      What i need to produce (reversed because I
'                                                                      realised quickly that I could only redim
'                                                                      last dimension)
'ActiveSheet.Comments looks like in my SS
'row     # of notes                                             arrNotes(0,0)   arrNotes(0,1)
'                                                                          # of notes        row
'35         1                                                                 1           35
'86         1                                                                 1           86
'90         1                                                                 3           90
'90         1
'90         1


I need the ActiveSheet.comments collection converted into a 2D array so can populate the last column using this code:
Code:
     'populate notes column
    For i = 0 To UBound(arrNotes, 2)
        Cells(arrNotes(1, i), ThisWorkbook.newLastCol(ActiveSheet)).Value = arrNotes(0, i)
    Next i

I have made four attempts. None work. When the last item in the collection is compared to an item that doesn't exist, an error is produced. I just can't figure out the logic. I'm not an idiot, I know checking for a value that doesn't exist is going to produce an error. Maybe I need another condition that checks if the loop is at the end of the collection & array and stop it comparing? But this just seems over-complicated and inefficient.

Here are my attempts. Attempt 1:
Code:
Sub countNotess()
    Dim i As Integer
    Dim ASCs As Comments
    Dim arrNotes() As Integer
    
    'ASCs = ActiveSheet.Comments
    
    'loop through each comment in SS
    For i = 0 To ActiveSheet.Comments.Count - 1
        'redim the array on first iteration
        If i = 0 Then
            'do this before the loop and the array will always grow even if counter increases
            ReDim Preserve arrNotes(1, i)
            arrNotes(0, i) = 1 'note
            arrNotes(1, i) = ActiveSheet.Comments(i + 1).Parent.row 'row
        Else
            'check if counter has not already started for this row
            If ActiveSheet.Comments(i + 1).Parent.row > arrNotes(1, i - 1) Then
                ReDim Preserve arrNotes(1, i)
                arrNotes(0, i) = 1 'note
                arrNotes(1, i) = ActiveSheet.Comments(i + 1).Parent.row ' row
            Else 'counter already started for this row so increase existing counter
                arrNotes(0, i - 1) = arrNotes(0, i - 1) + 1
            End If
        End If
    Next i
    
    'populate notes column
    For i = 0 To UBound(arrNotes, 2)
        Cells(arrNotes(1, i), ThisWorkbook.newLastCol(ActiveSheet)).Value = arrNotes(0, i)
    Next i
End Sub

Attempt 2:
Code:
Sub countNotesx()
    Dim c As Comment
    Dim i As Integer
    Dim arrNotes() As Integer
    
    'loop through each comment in SS
    For i = ActiveSheet.Comments.Count - 1 To 0 Step -1
        If i > 0 Then
            If ActiveSheet.Comments(i + 1).Parent.row > ActiveSheet.Comments(i).Parent.row Then
                ReDim Preserve arrNotes(1, i)
                arrNotes(0, i) = 1 'note
                arrNotes(1, i) = ActiveSheet.Comments(i + 1).Parent.row 'row
            Else
                arrNotes(0, i) = arrNotes(0, i) + 1
            End If
        Else
            ReDim Preserve arrNotes(1, i)
            arrNotes(0, i) = 1 'note
            arrNotes(1, i) = ActiveSheet.Comments(i + 1).Parent.row 'row
        End If
    Next i
End Sub

Attempt 3:
Code:
Sub countNotespppp()
    Dim c As Comment
    Dim i As Integer
    Dim arrNotes() As Integer
    
    'loop through each comment in SS
    For i = 0 To ActiveSheet.Comments.Count - 1
        If i = 0 Then
            ReDim Preserve arrNotes(1, i)
            arrNotes(0, i) = 1 'note
            arrNotes(1, i) = ActiveSheet.Comments(i + 1).Parent.row 'row
        Else
            If ActiveSheet.Comments(i).Parent.row < ActiveSheet.Comments(i + 1).Parent.row Then
                ReDim Preserve arrNotes(1, i)
                arrNotes(0, i) = 1 'note
                arrNotes(1, i) = ActiveSheet.Comments(i + 1).Parent.row 'row
            Else
                Do While ActiveSheet.Comments(i - 1).Parent.row = ActiveSheet.Comments(i).Parent.row
                    arrNotes(0, i) = arrNotes(0, i) + 1 'note
                    i = i - 1 'ensure pointless iterations aren't made
            End If
        End If
    Next i
End Sub

Attempt 4:
Code:
Sub countNotes()
    Dim n As Comment
    Dim i As Integer
    Dim arrNotes() As Integer
    
    i = 0
    
    'loop through each comment in SS
    Do While i < ActiveSheet.Comments.Count - 1
        ReDim Preserve arrNotes(1, i)
        arrNotes(0, i) = 1 'note
        arrNotes(1, i) = ActiveSheet.Comments(i + 1).Parent.row 'row
        
        Do While ActiveSheet.Comments(i + 1).Parent.row = ActiveSheet.Comments(i + 2).Parent.row
            arrNotes(0, i) = arrNotes(0, i) + 1 'note
            i = i + 1
        Loop
        
        Debug.Print arrNotes(0, i)
        Debug.Print arrNotes(1, i)
        
        i = i + 1
    Loop
End Sub

I hope everyone realises I've tried and tried before asking for help. Any help, even if it's just in pseudocode form, would be greatly appreciated.

Thanks,
Liam
 
Last edited:

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
My assumption is you require to count the number of Comments per row and place that count in the last column of each related row.
On that basis, try this:-
NB:- I have taken the last column (comment count column) as being the last cell in row 1, alter as required.
Code:
[COLOR="Navy"]Sub[/COLOR] MG22Feb25
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] LstCol [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
LstCol = Cells("1", Columns.Count).End(xlToLeft).Column

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] n = 1 To ActiveSheet.Comments.Count
        [COLOR="Navy"]If[/COLOR] Not .exists(ActiveSheet.Comments(n).Parent.Row) [COLOR="Navy"]Then[/COLOR]
            .Add ActiveSheet.Comments(n).Parent.Row, 1
        [COLOR="Navy"]Else[/COLOR]
            .Item(ActiveSheet.Comments(n).Parent.Row) = _
            .Item(ActiveSheet.Comments(n).Parent.Row) + 1
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    Cells(K, LstCol) = .Item(K)
[COLOR="Navy"]Next[/COLOR] K

[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Thanks Mick. Works a treat. Would never have gotten to this solution myself so appreciate your help.

Liam
 
Upvote 0
Here is another macro that should also work...
Code:
[table="width: 500"]
[tr]
	[td]Sub MG22Feb25()
  Dim Cell As Range, CommentCnt() As Long
  ReDim CommentCnt(1 To Cells.Find("*", , xlValues, , xlRows, xlPrevious, , , False).Row, 1 To 1)
  For Each Cell In Cells.SpecialCells(xlComments)
    CommentCnt(Cell.Row, 1) = CommentCnt(Cell.Row, 1) + 1
  Next
  Cells(1, 1 + Cells.Find("*", , xlValues, , xlByColumns, xlPrevious, , , False).Column).Resize(UBound(CommentCnt)) = CommentCnt
End Sub[/td]
[/tr]
[/table]
 
Upvote 0

Forum statistics

Threads
1,222,229
Messages
6,164,733
Members
451,911
Latest member
HMF009

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