如何按CHR（10）分割并移动细胞？

Question

我有一堆包含这样数据的单元格。

1. 更新贷款信息

2. 批准贷款信息

3. 更新公平信息

4. 批准信息

我想将其拆分为4个单独的单元格，并下拉ColA和ColC中的数据。

所以，如果A1：C1看起来像这样。

7   1. Update Lending Information   Conditional on question(s):
    2. Approve Lending Information
    3. Update Fair Information
    4. Approve Information

我希望A4：C4在代码运行后看起来像这样。

7     1. Update Lending Information    Conditional on question(s):
7     2. Approve Lending Information   Conditional on question(s):
7     3. Update Fair Information       Conditional on question(s):
7     4. Approve Information           Conditional on question(s):

这是我的非工作代码。

Sub TestingScript()

Dim c As Integer
LRow = Sheets("Exception Report").Range("A" & Rows.Count).End(xlUp).Row

For c = LRow To 1 Step -1
    Range("B" & c).Select
    splitVals = Split(ActiveSheet.Range("B" & c).Value, Chr(10))
    totalVals = UBound(splitVals) / 2
    Range(Cells(ActiveCell.Row + 1, ActiveCell.Column), Cells(ActiveCell.Row + 1 + totalVals, ActiveCell.Column)).Value = splitVals

    'With Range("A:A").SpecialCells(xlCellTypeBlanks)
    '    .FormulaR1C1 = "=R[-1]C"
    '    .Value = .Value
    'End With
Next c

End Sub

Answer 1

你可以试试这个：

Option Explicit

Sub main()
    Dim iRow As Long, nRows As Long
    Dim arr As Variant

    With Sheets("Exception Report")
        For iRow = .Cells(.Rows.Count, 1).End(xlUp).Row To 1 Step -1
            With .Cells(iRow, 1)
                arr = Split(.Offset(, 1).value, Chr(10))
                nRows = UBound(arr)
                .Offset(1).Resize(nRows).EntireRow.Insert xlShiftDown
                .Resize(nRows + 1).value = .value
                .Offset(, 1).Resize(nRows + 1).value = .Application.Transpose(arr)
                .Offset(, 2).Resize(nRows + 1).value = .Offset(, 2).value
            End With
        Next
    End With
End Sub