Látom, még nem jártál erre.

Felgyorsítottam a makrót, ezt próbáld ki.

Sub valami()
    Application.ScreenUpdating = False
    For oszlop = 2 To ActiveSheet.UsedRange.Columns.Count
        For sor = 2 To ActiveSheet.UsedRange.Rows.Count
            sz = Cells(sor, 1)
            If sz = Cells(1, oszlop) And f = 0 Then
                Cells(sor, oszlop) = sor - 1: f = 1
            End If
            If Cells(sor, oszlop) = "" And oszlop - 1 = sz Then
                Cells(sor, oszlop).Select
                felso = Cells(sor, oszlop).End(xlUp).Row
                Cells(sor, oszlop) = sor - felso
            End If
        Next
        f = 0
    Next
   
    'Összes előfordulás másolása a B oszlopba
    For sor = 2 To ActiveSheet.UsedRange.Rows.Count
        Cells(sor, 1).Select
        oszlop = Selection.End(xlToRight).Column
        Cells(sor, 2) = Cells(sor, oszlop)
    Next
   
    'Első sor, és C:F oszlopok törlése
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Columns("C:F").Select
    Selection.Delete Shift:=xlToLeft
   
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub