Guru do Excel e Power BI

Sub RearranjaDados()
Dim k As Long, LR As Long, m As Long
  If Sheets("Plan2").[A2] <> "" Then
   Sheets("Plan2").Range("A2:J" & Sheets("Plan2").Cells(Rows.Count, 1).End(3).Row).Value = ""
  End If
   For k = 2 To Cells(Rows.Count, 1).End(3).Row
    m = Application.CountIf([A:A], Cells(k, 1))
    With Sheets("Plan2")
     LR = .Cells(.Rows.Count, 1).End(3).Row
     .Cells(LR + 1, 1).Resize(, 3).Value = Cells(k, 1).Resize(, 3).Value
     .Cells(LR + 1, 4) = m
     .Cells(LR + 1, 5).Resize(, m).Value = Application.Transpose(Cells(k, 4).Resize(m).Value)
     k = k + m - 1
    End With
   Next k
End Sub