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

拆分细胞并分割数量较多的分裂

1 个答案: