如何使用excel VBA拆分和重新构造单元格

我当前使用的代码拆分：

并将其更改为：

但是，我要求数据采用以下格式：

这是我当前代码的副本：

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

---

如有任何帮助/意见，我们将不胜感激。

请在代码末尾致电

ResizeToFit

macro

将

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

Sub-ResizeToFit（）
Application.ScreenUpdating=False
我想我会坚持多久
对于i=范围（“D”和Rows.Count）。结束（xlUp）。行到1步骤-1
如果为空（范围（“D”&i）），则
行（i&“：”&i）。删除
其他的
范围（“E”和i）=分割（范围（“D”和i），Chr（32））（1）
范围（“D”和i）=分割（范围（“D”和i），Chr（32））（0）
如果结束
接下来我
对于i=1到5
如果我4岁的话
单元格（1，i）。调整大小（范围（“D”和行数）。结束（xlUp）。行数，1）。值=单元格（1，i）
如果结束
下一个
Application.ScreenUpdating=True
端接头

拿着这个

运行我的代码会产生

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
        Dim curRow As Integer
        curRow = lRow + lLFs
        While curRow >= lRow
            If Application.CountA(Rows(curRow).EntireRow) = 0 Then
                Rows(curRow).Delete
            Else
                rColumn.Cells(curRow).Offset(0, 1).Value = Split(rColumn.Cells(curRow), " ")(1)
                rColumn.Cells(curRow).Value = Split(rColumn.Cells(curRow), " ")(0)
                rColumn.Cells(curRow).Offset(0, -3).Value = rColumn.Cells(lRow).Offset(0, -3).Value
                rColumn.Cells(curRow).Offset(0, -2).Value = rColumn.Cells(lRow).Offset(0, -2).Value
                rColumn.Cells(curRow).Offset(0, -1).Value = rColumn.Cells(lRow).Offset(0, -1).Value
            End If
            curRow = curRow - 1
        Wend
    Next lRow
End Sub

---

这只是录制的宏，因此需要清理

ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],LEN(RC[-1])-5)"
    Range("E1:E4").Select
    Selection.FillDown
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],4)"
    Range("F1:F4").Select
    Selection.FillDown
    Range("E1:F4").Select
    Selection.Copy
    Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft

如果您对D列保持原样并使拆分部分位于右侧感到满意，则可能不需要剪切、粘贴和删除列。那么

ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],LEN(RC[-1])-5)"
    Range("E1:E4").Select
    Selection.FillDown
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],4)"
    Range("F1:F4").Select
    Selection.FillDown

---

抱歉-ActiveCell是E1。

@Chris我已经编辑了我的答案，以证明它做了您希望它做的事情……您一定是做错了什么，或者没有提供所有必需的详细信息。请确保D列中可见的空单元格实际上是空的，

IsEmpty（cell）

才能正常工作。。尝试将条件从

IsEmpty（Range（“D”）和i））

更改为

Len（Range（“D”）和i））=0

Pefect，成功了！有一个空间导致了问题！

ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],LEN(RC[-1])-5)"
    Range("E1:E4").Select
    Selection.FillDown
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],4)"
    Range("F1:F4").Select
    Selection.FillDown