Option Explicit
'Выделите ячейки, запустите макрос "Разделить".
Sub Разделить()
    CloseEmptyWb
    ActiveSheet.Copy
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    SplitRange rr
End Sub

Sub SplitRange(rr As Range)
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    Dim rArea As Range
    For Each rArea In rr.Areas
        SplitArea rArea
    Next
    
    Application.Calculation = Application_Calculation
    rr.Parent.Parent.Saved = True
    Application.ScreenUpdating = True
End Sub

Sub SplitArea(rr As Range)
    Dim yr As Long
    For yr = rr.Rows.Count To 1 Step -1
        SplitRow rr.Rows(yr)
    Next
End Sub

Sub SplitRow(rr As Range)
    Dim arr As Variant
    If rr.Cells.Count = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    
    Dim brr As Variant, xa As Long, nRow As Long
    nRow = 1
    ReDim brr(1 To UBound(arr, 2))
    For xa = 1 To UBound(brr)
        brr(xa) = Split(arr(1, xa), Chr(10))
        If LBound(brr(xa)) > UBound(brr(xa)) Then brr(xa) = Array(Empty)
        nRow = nRow * (UBound(brr(xa)) - LBound(brr(xa)) + 1)
    Next
    
    Dim yrr As Variant, orr As Variant, yo As Long
    ReDim yrr(1 To UBound(brr)) As Long
    ReDim orr(1 To nRow, 1 To UBound(brr))
    
    Dim xy As Long
    xy = UBound(yrr)
    Do
        If yo = UBound(orr, 1) Then Exit Do
        recu yrr, xy, brr, orr, yo
        DoEvents
    Loop
    If nRow > 1 Then
        rr.Rows(1).EntireRow.Copy
        rr.Rows(2).Resize(nRow - 1).EntireRow.Insert Shift:=xlDown
        Application.CutCopyMode = False
        rr.Resize(UBound(orr, 1), UBound(orr, 2)).Value = orr
    End If
End Sub

Private Sub recu(yrr As Variant, xy As Long, brr As Variant, orr As Variant, yo As Long)
    yo = yo + 1
    FillArrayRow orr, yo, brr, yrr
    
    yrr(xy) = yrr(xy) + 1
    If yrr(xy) > UBound(brr(xy)) Then
        Dim xo As Long
        For xo = xy To UBound(yrr)
            yrr(xo) = LBound(brr(xo))
        Next
        For xo = xy - 1 To LBound(yrr) Step -1
            yrr(xo) = yrr(xo) + 1
            If yrr(xo) <= UBound(brr(xo)) Then Exit For
            yrr(xo) = LBound(brr(xo))
        Next
        
        xy = UBound(yrr)
    End If
End Sub

Private Sub FillArrayRow(orr As Variant, yo As Long, brr As Variant, yrr As Variant)
    Dim xo As Long
    For xo = 1 To UBound(orr, 2)
        orr(yo, xo) = brr(xo)(yrr(xo))
    Next
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub