Opsamle navne fra forskellige celler og sætte dem ind i et kommentarfelt i excel

Et eksempel ville være fint - evt. er du velkommen til at sende en model - @-adresse under min profil.

Dim antalRæk As Long, antalKol As Long
Dim farve, navn As String, antal As Byte
Dim ræk As Long
Dim antalTeamRæk As Byte
Const startRæk = 4
Public Sub opSamling()
Dim t As Long, k As Long
    Application.ScreenUpdating = False
   
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
    antalKol = ActiveCell.SpecialCells(xlLastCell).Column
   
    resetKom
   
    For ræk = startRæk To antalRæk
        teamRæk = beregnAntalTeamRækker(ræk)
       
        For k = 2 To antalKol
            For t = ræk To ræk + teamRæk - 1
                If Cells(t, k) <> "" Then
                    If navn = "" Then
                        navn = Range("A" & t) & vbLf
                    Else
                        navn = navn & Range("A" & t) & vbLf
                    End If
                    antal = antal + 1
                End If
            Next t
           
            opdaterTeam navn, antal, k, farve
            resetKom
            ActiveWorkbook.Sheets("Ark2").Activate
        Next k
        farve = ""
        ræk = ræk + teamRæk - 1
    Next ræk
   
    ActiveWorkbook.Sheets("Ark1").Activate
    Application.ScreenUpdating = True
End Sub
Private Sub resetKom()
    navn = ""
    antal = 0
End Sub
Private Function beregnAntalTeamRækker(fraRæk) As Byte
Dim ræk As Long
    farve = Range("A" & fraRæk).Interior.ColorIndex
    beregnAntalTeamRækker = 1
   
    For ræk = fraRæk + 1 To antalRæk
        If Range("A" & ræk).Interior.ColorIndex = farve Then
            beregnAntalTeamRækker = beregnAntalTeamRækker + 1
        Else
            Exit For
        End If
    Next ræk
End Function
Private Sub opdaterTeam(navn, antal, kol, farve)
Dim ræk As Long
    ActiveWorkbook.Sheets("Ark1").Activate
    For ræk = startRæk To antalRæk
        If ActiveSheet.Range("A" & ræk).Interior.ColorIndex = farve Then
            ActiveSheet.Cells(ræk, kol).Value = antal
           
            If antal > 0 Then
                ActiveSheet.Cells(ræk, kol).AddComment Text:=navn
            End If
            Exit Sub
        End If
    Next ræk
   
    MsgBox "Farve ikke fundet"
    Stop
End Sub