Разбить клетки и разделить нульбер числа сплитов

Question

Мне нужна ваша помощь, поскольку я пытаюсь получить следующие выходные данные из необработанных данных ниже.

Необработанные данные:

A            B
Customer    Budget
"AAA
BBB         300
CCC"
BBB         150
"EEE
AAA"        30

Требуемый вывод:

Customer    Budget
AAA           100
BBB           100
CCC           100
BBB           150
EEE           15
AAA           15

По сути, я хотел бы разбить ячейки, содержащие текст на разные строки (alt + enter).Мне удалось разделить ячейки и просто скопировать вставку ниже, используя следующий макрос:

Sub SplitMacro()

'working for active sheet
'copy to the end of sheets collection

ActiveSheet.Copy after:=Sheets(Sheets.Count)
Dim tmpArr As Variant
Dim Cell As Range
For Each Cell In Range("AE1", Range("AE2").End(xlDown))
    If InStr(1, Cell, Chr(10)) <> 0 Then
        tmpArr = Split(Cell, Chr(10))
        Cell.EntireRow.Copy
        Cell.Offset(1, 0).Resize(UBound(tmpArr), 1). _
            EntireRow.Insert xlShiftDown

        Cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)
        Cell.EntireRow.Interior.Color = RGB(120, 120, 225)


    End If
Next
Application.CutCopyMode = False
End Sub

Однако я не смог разделить ячейки бюджета на количество значений из столбца A. Любойпомогите добро пожаловать!

Большое спасибо

Answer 1

Добавьте строку:

        Cell.Offset(, 1).Resize(UBound(tmpArr) + 1, 1) = Cell.Offset(, 1).Value2 / (UBound(tmpArr) + 1)

Чуть выше End If.

Это разделит число, найденное в ячейке справа, на количество добавляемых строк:

Sub SplitMacro()

'working for active sheet
'copy to the end of sheets collection

ActiveSheet.Copy after:=Sheets(Sheets.Count)
Dim tmpArr As Variant
Dim Cell As Range
For Each Cell In Range("AE1", Range("AE2").End(xlDown))
    If InStr(1, Cell, Chr(10)) <> 0 Then
        tmpArr = Split(Cell, Chr(10))
        Cell.EntireRow.Copy
        Cell.Offset(1, 0).Resize(UBound(tmpArr), 1). _
            EntireRow.Insert xlShiftDown

        Cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)
        Cell.EntireRow.Interior.Color = RGB(120, 120, 225)
        Cell.Offset(, 1).Resize(UBound(tmpArr) + 1, 1) = Cell.Offset(, 1).Value2 / (UBound(tmpArr) + 1)

    End If
Next
Application.CutCopyMode = False
End Sub