CODEWITHSUNDEEP
vbaexcel
Chris
Chris

Reputation: 99

How to split and restructure cells using excel VBA

The code I currently use splits:

Original Data

And changes it to:

Modified Data

However, this is the format in which I require the data to be in:

Required Format

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.

Upvotes: 2

Views: 958

Answers (3)

Inch High
Inch High

Reputation: 15

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.

Upvotes: 0

user2140173
user2140173

Reputation:

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

enter image description here

and running my code produces

enter image description here

Upvotes: 3

brWHigino
brWHigino

Reputation: 260

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

Upvotes: 0

Related Questions