split values in cells into new row

[missy22]

I am writing to seek help, in how I can split values in certain cells, in many different rows.

For example, I would like to split values, into new row entry which are represented as the following:
Value1 & value & value3
Value4 & value, value8

Desired output:
Value1
Value
Value3
Value4
Value…. So on.

I have also attached a sample data example, showing input data in sheet1 and desired output in sheet2, for further reference.
test_v2.xls

any further help would be very much appreciated. Thank you

[apo]

Hi..

Try this..

Result shown on sheet3..

Private Sub CommandButton1_Click()
    Dim x, y, b, cnt As Long, k As Long, s As Long, j As Long, i As Long, ii As Long, LR As Long
    With Range("A1").CurrentRegion
        .Replace "&", ","
        x = .Value
        cnt = 1: k = 1: s = 1
        LR = Range("A" & Rows.Count).End(xlUp).Row
        b = Evaluate("=SUMPRODUCT(LEN(A1:A" & LR & ")-LEN(SUBSTITUTE(A1:A" & LR & ",CHAR(44),"""")))") + LR
        ReDim y(1 To b, 1 To 4)
        For i = 1 To b
            For j = 0 To UBound(Split(x(cnt, 1), Chr(44)))
                For ii = 1 To UBound(x, 2)
                    If ii = 1 Then
                        y(k, ii) = Trim(Split(x(cnt, 1), Chr(44))(j))
                    ElseIf ii = 3 Then
                        If UBound(Split(x(cnt, 3), Chr(44))) > 0 Then
                            y(k, ii) = Trim(Split(x(cnt, 3), Chr(44))(j))
                        Else
                            y(k, ii) = x(cnt, 3)
                        End If
                    Else
                        y(k, ii) = Trim(x(cnt, ii))
                    End If
                Next ii
                If s = UBound(Split(x(cnt, 1), Chr(44))) + 1 Then
                    k = k + 1: cnt = cnt + 1: Exit For
                Else
                    k = k + 1: s = s + 1
                End If
            Next j
            s = 1
            If k > b Then
                With Sheets("Sheet3")
                    .Range("A1").Resize(UBound(y), 4).Value = y
                    .Columns(4).NumberFormat = "mm/dd/yyyy"
                    .Columns.AutoFit
                    .Select
                End With
                Exit Sub
            End If
        Next i
    End With
End Sub

btw.. I replaced your "&" character with a comma so you had a common delimiter to work with..

[walruseggman]

Another Approach:

Sub missy22()
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = LastRow To 1 Step -1
    Namess = Replace(Cells(i, 1).Value, ", ", " & ")
    Money = Replace(Cells(i, 3).Value, ", ", " & ")
    
    If InStr(1, Namess, "&") Then
        For j = UBound(Split(Namess, " & ")) To 0 Step -1
            Rows(i + 1).EntireRow.Insert
            Rows(i).Copy Rows(i + 1)
            Cells(i + 1, 1) = Split(Namess, " & ")(j)
            If InStr(1, Money, "&") Then Cells(i + 1, 3) = Split(Money, " & ")(j)
        Next
        Rows(i).EntireRow.Delete
    End If
Next
Application.ScreenUpdating = True
End Sub

[xladept]

And yet another:

Sub Missy(): Dim S As String, X, Z, A As Range, C As Range
Dim e As Long, i As Long, u As Integer, n As Integer, m As Integer
e = Range("A" & Rows.Count).End(xlUp).Row
For i = e To 1 Step -1: Set A = Range("A" & i): Set C = Range("C" & i)
S = Replace(A, ",", "&"): Z = Split(S, "&"): u = UBound(Z)
S = Replace(C, ",", "&"): X = Split(S, "&"): A = Z(0): C = X(0)
                        If u Then
            For n = 1 To u: A.Offset(n).EntireRow.Insert
            If UBound(Z) = UBound(X) Then m = n Else m = 0
    A.Offset(n, 0) = Z(n): A.Offset(n, 1) = A.Offset(0, 1)
    A.Offset(n, 2) = X(m): A.Offset(n, 3) = A.Offset(0, 3)
            Next n
                        End If: Next i: End Sub