hjælp til excel fil - kontaktpersoner skal stå i samme række og ikke i f.eks. 3 rækker!

Der skal skrives en snut VBA kode - ikke noget der tager lang tid.
Smid mig en mail, hvis du ikke kan få løst opgaven for point.

Forslag (havde noget tilsvarende fra tidl. spørgsmål)
Koden indsættes under relevante ark - udføres v/Alt+F8 - afspil makro fraRækkerTilKolonner

Dim antalRækker As Long, ptNr, ptVirk As String, ptNavn As String, nr
Dim ræk As Long, nyRæk As Long, antalNavne As Long, maxAntal
Public Sub fraRækkerTilKolonne()
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
    nyRæk = 2
    maxAntal = 1
    antalNavne = 0

    Application.ScreenUpdating = False
    For ræk = 2 To antalRækker
        hentData
       
        If ræk = 2 Then
            nyeData
        Else
            If ptNr = nr Then
                Range("G" & nyRæk).Offset(0, antalNavne) = ptNavn
                antalNavne = antalNavne + 1
                If antalNavne > maxAntal Then
                    maxAntal = antalNavne
                End If
            Else
                nyRæk = nyRæk + 1
                nyeData
            End If
        End If
    Next ræk
   
Rem Opsætning af Navn2....NavX
    opsætOverskrifter maxAntal - 1
   
    Columns.AutoFit
    ScreenUpdating = True
End Sub
Private Sub hentData()
    ptNr = Range("A" & ræk)
    ptVirk = Range("B" & ræk)
    ptNavn = Range("C" & ræk)
End Sub
Private Sub nyeData()
    nr = ptNr
   
    Range("E" & nyRæk) = ptNr
    Range("F" & nyRæk) = ptVirk
    Range("G" & nyRæk) = ptNavn
    antalNavne = 1
End Sub
Private Sub opsætOverskrifter(antal)
Dim kol
    If antal > 1 Then
        For kol = 1 To antal
            Range("G1").Offset(0, kol) = "Navn" & CStr(kol + 1)
        Next kol
    End If
End Sub

Tak for jeres hjælp - vil få en kollega til at forsøge sig med det sidstnævnte..