How to separate cell values and insert into new rows

**dj7616** · 05-22-2013, 12:41 PM

Hi all,
I am looking for a macro to look at a colum with a cell that has values that are separated by a comma or a space or a carriage return and make new rows with only a single value for that column of cells. I am sorry that sounds confusing but I have attached a sample worksheet. In the worksheet, I am looking at Column B and want to separate them into different lines but copy Column A and Column C for the new line. So I did the first one, which is row 2 was separated to row 3 and row 4. Any help on this would be great.

**tehneXus** · 05-22-2013, 04:17 PM

Hi,

click the button on the first sheet and check result on 2nd sheet: test_multiple_cells.xlsm

contains:

Option Explicit

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    RestrucData
    Application.ScreenUpdating = True
End Sub

Sub RestrucData()
    Dim dicData As Object: Set dicData = CreateObject("Scripting.Dictionary")
    Dim dicChild As Object
    Dim aData, sValue
    Dim lngMaxRows As Long, i As Long, j As Integer
    
    With ThisWorkbook.Worksheets("Sheet1") 'adapt sheetname
        lngMaxRows = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lngMaxRows
        
            sValue = .Cells(i, 2).Value
            If InStr(sValue, vbLf) > 0 Then 'return
                aData = Split(sValue, vbLf)
            ElseIf InStr(sValue, ",") > 0 Then 'comma
                aData = Split(sValue, ",")
            ElseIf InStr(sValue, " ") > 0 Then 'space
                aData = Split(sValue, " ")
            End If
            
            Set dicChild = CreateObject("Scripting.Dictionary")
            If IsArrayAllocated(aData) Then
                For j = LBound(aData) To UBound(aData)
                    dicChild(j) = Array(.Cells(i, 1).Value, Trim(aData(j)), .Cells(i, 3).Value)
                Next j
                Erase aData
            Else
                dicChild(0) = Array(.Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, 3).Value)
            End If
            dicData.Add i, dicChild
        Next i
    End With
        
    With ThisWorkbook.Worksheets("Sheet2") 'adapt sheetname
        lngMaxRows = .Cells(.Rows.Count, 1).End(xlUp).Row
        For Each aData In dicData.Keys
            For Each sValue In dicData(aData).Keys
                .Range(.Cells(lngMaxRows, 1), .Cells(lngMaxRows, 3)).Value = dicData(aData)(sValue)
                lngMaxRows = lngMaxRows + 1
            Next sValue
        Next aData
        .Activate
    End With
        
End Sub

Function IsArrayAllocated(arr) As Boolean
    On Error GoTo ErrHandler
    Dim tmpVal
    tmpVal = LBound(arr)
    IsArrayAllocated = True
    Exit Function
ErrHandler:
    IsArrayAllocated = False
End Function

**scott.s.fower** · 05-22-2013, 05:23 PM

this works based on your test_multiple_cells.xlsx
run this macro

Function NthWord(Words As String, N As Integer) As String
   'Extracts the Nth word from the string Words
   Dim WordArray     As Variant
   WordArray = Split(Words)
   If UBound(WordArray) < N - 1 Then
      NthWord = "#N/A"
   Else
      NthWord = WordArray(N - 1)
   End If
End Function


Sub Loop_Example()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lrow As Long

    With ActiveSheet

        Firstrow = 2
        Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

        For Lrow = Lastrow To Firstrow Step -1

            With .Cells(Lrow, "B")

                If Not IsError(.Value) Then

                    If .Value Like "*, *" Then
                        x = Range("B" & Lrow)
                        Range("B" & Lrow).Value = Replace(x, ", ", Chr(32))
                    End If
                    
                    If .Value Like "* *" Then
                        x = Range("B" & Lrow)
                        Range("B" & Lrow).Value = Replace(x, " ", Chr(32))
                    End If
                    
                    b = Chr(10)
                    c = " "
                    Range("B:B").Replace What:=b, Replacement:=c, LookAt:=xlPart, SearchOrder _
                        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
                
                End If

            End With

        Next Lrow
        
        For Lrow = Lastrow To Firstrow Step -1

            With .Cells(Lrow, "B")

                If Not IsError(.Value) Then

                    x = Range("B" & Lrow)
 
                    Ln = Len(x) - Len(Replace(x, " ", ""))
                    If Ln > 0 Then
                        Range(Range("B" & Lrow + 1), Range("B" & Lrow + Ln)).EntireRow.Insert (2)
                    Else:
                    End If
                    For i = Lrow + 1 To Lrow + Ln
                    x = Range("B" & Lrow)
                        Range("A" & i).FillDown
                        Range("C" & i).FillDown
                        theword = NthWord(Range("B" & Lrow).Value, 2)
                        Range("B" & i).Value = theword
                        Range("B" & Lrow).Value = Replace(x, " " & theword, "")
                    Next
                    End If

            End With

        Next Lrow
        
       

    End With

End Sub