Sub An()
Dim a(), i&, j&, k&, s$, d$()
  a = Range("A1").CurrentRegion.Resize(, 2).Value2
  i = 1: k = 1
  Worksheets.Add , ActiveSheet
  Do
    s = a(i, 2)
    For j = i + 1 To UBound(a)
      If IsEmpty(a(j, 2)) Then
        s = s & IIf(Right$(s, 1) = ",", "", ",") & a(j, 1)
      Else: Exit For
      End If
    Next
    d = Split(s, ",")
    Cells(k, 1) = a(i, 1)
    Cells(k, 2).Resize(UBound(d) + 1).Value = WorksheetFunction.Transpose(d)
    k = k + UBound(d) + 1
    i = j
  Loop Until i > UBound(a)
End Sub