Макросом разнести данные движения склада в плоский файл - VBA

Option Explicit
 
Sub tt()
Dim c As Range, r As Range, x As Long, i As Long, ii As Long
Dim t As String, tt As String, fio As String, arr
 
Set r = Sheets(1).[b9].CurrentRegion
 
ReDim a(1 To r.Rows.Count - 4, 1 To 7)
x = x + 1
a(x, 1) = "Дата"
a(x, 2) = "Склад"
a(x, 3) = "Номенклатура"
a(x, 4) = "Количество"
a(x, 5) = "Документ"
a(x, 6) = "Приход/Расход"
a(x, 7) = "Контрагент"
 
For i = 4 To r.Rows.Count
    Select Case r.Rows(i).Cells(1).IndentLevel
        Case 0
        If r.Rows(i).Cells(1).Font.Bold = True Then t = r.Rows(i).Cells(1)
        Case 1
        If r.Rows(i).Cells(1).Font.Bold = True Then tt = r.Rows(i).Cells(1)
        Case 2
        arr = Split(r.Rows(i).Cells(1), ",")
        fio = arr(UBound(arr))
            For ii = 2 To r.Columns.Count
                If r.Rows(i).Cells(ii) > 0 Then
                x = x + 1
                a(x, 1) = r.Rows(1).Cells(ii).MergeArea.Cells(1) '"Дата"
                a(x, 2) = t '"Склад"
                a(x, 3) = tt '"Номенклатура"
                a(x, 4) = r.Rows(i).Cells(ii) '"Количество"
                arr = Split(r.Rows(i).Cells(1), " от ")
                a(x, 5) = arr(0) '"Документ"
                a(x, 6) = r.Rows(3).Cells(ii) '"Приход/Расход"
                a(x, 7) = fio '"Контрагент"
                End If
            Next
    End Select
Next
 
With Workbooks.Add(1).Sheets(1).[a1].Resize(x, 7)
    .Columns(4).NumberFormat = "0.000"
    .Value = a
    .Columns.AutoFit
End With
 
End Sub