如何使用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宏

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

即

...
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

采取这个

并运行我的代码生成

Answer 2

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

Answer 3

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

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。