Как разделить и реструктурировать клетки с помощью 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.