vba - 如何使用 Excel VBA 拆分和重组单元格

Question

我当前使用的代码拆分:

并将其更改为:

但是，这是我要求数据采用的格式:

这是我当前代码的副本:

Sub SplitCells()
Dim rColumn As Range
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lRow As Long
Dim lLFs As Long

Set rColumn = Columns("D")
lFirstRow = 1
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).Row

For lRow = lLastRow To lFirstRow Step -1
    lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, ""))
    If lLFs > 0 Then
        rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert xlShiftDown
        rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf))
    End If
Next lRow
End Sub

任何帮助/评论将不胜感激。

Answer 1

在代码末尾调用 ResizeToFit 宏

在当前代码中的 End Sub 之前添加 ResizeToFit

即。

...
Next lRow
ResizeToFit ' or Call ResizeToFit
End Sub
...

将此代码作为新子添加到同一模块中

Sub ResizeToFit()
Application.ScreenUpdating = False

    Dim i As Long
    For i = Range("D" & Rows.Count).End(xlUp).Row To 1 Step -1
        If IsEmpty(Range("D" & i)) Then
            Rows(i & ":" & i).Delete
        Else
            Range("E" & i) = Split(Range("D" & i), Chr(32))(1)
            Range("D" & i) = Split(Range("D" & i), Chr(32))(0)
        End If
    Next i

    For i = 1 To 5
        If i <> 4 Then
            Cells(1, i).Resize(Range("D" & Rows.Count).End(xlUp).Row, 1).Value = Cells(1, i)
        End If
    Next

Application.ScreenUpdating = True
End Sub

拿这个

运行我的代码会产生