How to split and restructure cells using excel VBA - vba

Question

The code I currently use splits:
And changes it to:
However, this is the format in which I require the data to be in:
This is a copy of my current code:
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
Any help/comments will be appreciated.

Answer 1

call ResizeToFit macro at the end of your code
Add ResizeToFit right before End Sub in your current code
ie.
...
Next lRow
ResizeToFit ' or Call ResizeToFit
End Sub
...
add this code to the same module as a new 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
Taking THIS
and running my code produces

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

This is just from a recorded macro so it needs cleaning up.
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
You may not need the cut, paste and column delete if you're happy with Column D staying as it is and having the split parts to the right. In which case
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
Sorry - ActiveCell is E1.