Sub Мяу()
    Dim arr, i&, k&, j&
    arr = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row).Value
    For i = UBound(arr) To 1 Step -1
        If InStr(arr(i, 1), ",") Then
            For j = 1 To Len(arr(i, 1))
                If Mid$(arr(i, 1), j, 1) = "," Then
                    k = k + 1
                End If
            Next
            Rows(i).Copy
            Rows(i & ":" & i + k - 1).Insert Shift:=xlDown
            k = 0
        End If
    Next
    arr = Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row).Value
    On Error Resume Next
    For i = 1 To UBound(arr)
        If InStr(arr(i, 1), ",") Then
            arr(i + 1, 1) = Mid$(arr(i, 1), InStr(arr(i, 1), ",") + 1)
            arr(i, 1) = Left$(arr(i, 1), InStr(arr(i, 1), ",") - 1)
        End If
    Next
    Range("D1").Resize(UBound(arr)) = arr
End Sub