CODEWITHSUNDEEP
excelvba
MJ95
MJ95

Reputation: 479

Split cell values into multiple rows and keep other data

I have values in column B separated by commas. I need to split them into new rows and keep the other data the same.

I have a variable number of rows.

I don't know how many values will be in the cells in Column B, so I need to loop over the array dynamically.

Example:

ColA       ColB       ColC      ColD
Monday     A,B,C      Red       Email

Output:

ColA       ColB       ColC      ColD
Monday       A         Red       Email
Monday       B         Red       Email
Monday       C         Red       Email

Have tried something like:

colArray = Split(ws.Cells(i, 2).Value, ", ")
For i = LBound(colArray) To UBound(colArray)
    Rows.Insert(i)
Next i

Upvotes: 11

Views: 36075

Answers (5)

Noah Bridge
Noah Bridge

Reputation: 345

Given @A.S.H.'s excellent and brief answer, the VBA function below might be a bit of an overkill, but it will hopefully be of some help to someone looking for a more "generic" solution. This method makes sure not to modify the cells to the left, to the right, or above the table of data, in case the table does not start in A1 or in case there is other data on the sheet besides the table. It also avoids copying and inserting entire rows, and it allows you to specify a separator other than a comma.

This function happens to have similarities to @ryguy72's procedure, but it does not rely on the clipboard.

Function SplitRows(ByRef dataRng As Range, ByVal splitCol As Long, ByVal splitSep As String, _
                   Optional ByVal idCol As Long = 0) As Boolean
  SplitRows = True

  Dim oldUpd As Variant: oldUpd = Application.ScreenUpdating
  Dim oldCal As Variant: oldCal = Application.Calculation

  On Error GoTo err_sub

  'Modify application settings for the sake of speed
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  'Get the current number of data rows
  Dim rowCount As Long: rowCount = dataRng.Rows.Count

  'If an ID column is specified, use it to determine where the table ends by finding the first row
  '  with no data in that column
  If idCol > 0 Then
    With dataRng
      rowCount = .Offset(, idCol - 1).Resize(, 1).End(xlDown).Row - .Row + 1
    End With
  End If

  Dim splitArr() As String
  Dim splitLb As Long, splitUb As Long, splitI As Long
  Dim editedRowRng As Range

  'Loop through the data rows to split them as needed
  Dim r As Long: r = 0
  Do While r < rowCount
    r = r + 1

    'Split the string in the specified column
    splitArr = Split(dataRng.Cells(r, splitCol).Value & "", splitSep)
    splitLb = LBound(splitArr)
    splitUb = UBound(splitArr)

    'If the string was not split into more than 1 item, skip this row
    If splitUb <= splitLb Then GoTo splitRows_Continue

    'Replace the unsplit string with the first item from the split
    Set editedRowRng = dataRng.Resize(1).Offset(r - 1)
    editedRowRng.Cells(1, splitCol).Value = splitArr(splitLb)

    'Create the new rows
    For splitI = splitLb + 1 To splitUb
      editedRowRng.Offset(1).Insert 'Add a new blank row
      Set editedRowRng = editedRowRng.Offset(1) 'Move down to the next row
      editedRowRng.Offset(-1).Copy Destination:=editedRowRng 'Copy the preceding row to the new row
      editedRowRng.Cells(1, splitCol).Value = splitArr(splitI) 'Place the next item from the split string

      'Account for the new row in the counters
      r = r + 1
      rowCount = rowCount + 1
    Next

splitRows_Continue:
  Loop

exit_sub:
  On Error Resume Next

  'Resize the original data range to reflect the new, full data range
  If rowCount <> dataRng.Rows.Count Then Set dataRng = dataRng.Resize(rowCount)

  'Restore the application settings
  If Application.ScreenUpdating <> oldUpd Then Application.ScreenUpdating = oldUpd
  If Application.Calculation <> oldCal Then Application.Calculation = oldCal
  Exit Function

err_sub:
  SplitRows = False
  Resume exit_sub
End Function

Function input and output

To use the above function, you would specify

  • the range containing the rows of data (excluding the header)
  • the (relative) number of the column within the range with the string to split
  • the separator in the string to split
  • the optional (relative) number of the "ID" column within the range (if a number >=1 is provided, the first row with no data in this column will be taken as the last row of data)

The range object passed in the first argument will be modified by the function to reflect the range of all the new data rows (including all inserted rows). The function returns True if no errors were encountered, and False otherwise.

Examples

For the range illustrated in the original question, the call would look like this:

SplitRows Range("A2:C2"), 2, ","

If the same table started in F5 instead of A1, and if the data in column G (i.e. the data that would fall in column B if the table started in A1) was separated by Alt-Enters instead of commas, the call would look like this:

SplitRows Range("F6:H6"), 2, vbLf

If the table contained the row header plus 10 rows of data (instead of 1), and if it started in F5 again, the call would look like this:

SplitRows Range("F6:H15"), 2, vbLf

If there was no certainty about the number of rows, but we knew that all the valid rows are contiguous and always have a value in column H (i.e. the 3rd column in the range), the call could look something like this: 

SplitRows Range("F6:H1048576"), 2, vbLf, 3

In Excel 95 or lower, you would have to change "1048576" to "16384", and in Excel 97-2003, to "65536".

Upvotes: 0

user3471272
user3471272

Reputation: 55

A formula solution is close to your requirement.

Image shown here.

Cell G1 is the delimiter. In this case a comma.

Helper E1:=SUM(E1,LEN(B1)-LEN(SUBSTITUTE(B1,$H$1,"")))+1

You must fill the above formula one row more. 

A8:=a1

Fill this formula to the right.

A9:=LOOKUP(ROW(1:1),$E:$E,A:A)&""

Fill this formula to the right and then down.

B9:=MID($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))+1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)+1))-FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))-1)&""

Fill down.

Bug:

Numbers will be converted to Text. Of course you can remove the &"" at the end of the formula, but blank cells will be filled with 0.

Upvotes: 1

ASH
ASH

Reputation: 20322

This will do what you want.

Option Explicit

Const ANALYSIS_ROW As String = "B"
Const DATA_START_ROW As Long = 1

Sub ReplicateData()
    Dim iRow As Long
    Dim lastrow As Long
    Dim ws As Worksheet
    Dim iSplit() As String
    Dim iIndex As Long
    Dim iSize As Long

    'Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With ThisWorkbook
        .Worksheets("Sheet4").Copy After:=.Worksheets("Sheet4")
        Set ws = ActiveSheet
    End With

    With ws
        lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
    End With


    For iRow = lastrow To DATA_START_ROW Step -1
        iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
        iSize = UBound(iSplit) - LBound(iSplit) + 1
        If iSize = 1 Then GoTo Continue

        ws.Rows(iRow).Copy
        ws.Rows(iRow).Resize(iSize - 1).Insert
        For iIndex = LBound(iSplit) To UBound(iSplit)
            ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
        Next iIndex
Continue:
    Next iRow

    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    'Application.ScreenUpdating = True
End Sub

Upvotes: 1

A.S.H
A.S.H

Reputation: 29332

Try this, you can easily adjust it to your actual sheet name and column to split.

Sub splitByColB()
    Dim r As Range, i As Long, ar
    Set r = Worksheets("Sheet1").Range("B999999").End(xlUp)
    Do While r.row > 1
        ar = Split(r.value, ",")
        If UBound(ar) >= 0 Then r.value = ar(0)
        For i = UBound(ar) To 1 Step -1
            r.EntireRow.Copy
            r.Offset(1).EntireRow.Insert
            r.Offset(1).value = ar(i)
        Next
        Set r = r.Offset(-1)
    Loop
End Sub

Upvotes: 18

Comintern
Comintern

Reputation: 22195

You can also just do it in place by using a Do loop instead of a For loop. The only real trick is to just manually update your row counter every time you insert a new row. The "static" columns that get copied are just a simple matter of caching the values and then writing them to the inserted rows:

Dim workingRow As Long
workingRow = 2
With ActiveSheet
    Do While Not IsEmpty(.Cells(workingRow, 2).Value)
        Dim values() As String
        values = Split(.Cells(workingRow, 2).Value, ",")
        If UBound(values) > 0 Then
            Dim colA As Variant, colC As Variant, colD As Variant
            colA = .Cells(workingRow, 1).Value
            colC = .Cells(workingRow, 3).Value
            colD = .Cells(workingRow, 4).Value
            For i = LBound(values) To UBound(values)
                If i > 0 Then
                    .Rows(workingRow).Insert xlDown
                End If
                .Cells(workingRow, 1).Value = colA
                .Cells(workingRow, 2).Value = values(i)
                .Cells(workingRow, 3).Value = colC
                .Cells(workingRow, 4).Value = colD
                workingRow = workingRow + 1
            Next
        Else
            workingRow = workingRow + 1
        End If
    Loop
End With

Upvotes: 3

Related Questions