VBA to extract string after specific character using loop

[asgsitting]

Hi I have a real simple VBA to right , but as I am really new to VBA I am very much struggling, though I understand the logic completely I just dont know how to write it in VBA. Can someone please help?

Problem follow:

A1: Mr Adam Smith & Mrs Celia Smith
A3: Mr A Ping & Mr Wa Chu
A5: Dr I Gupta & Dr V Gupta & Mr A Gupta


I need to extra Names in different Cells, so for A1
I need to extract
Mr Adam Smith (B1) Mrs Celia Smith (B2)

From A3:
B3: Mr A Ping
B4: Mr Wa Chu

From A5:
B5:Dr I Gupta
B6: Dr V Gupta
B7: Mr A Gupta

I can understand the logic that the pointer need to start from right and extract the words as it is until it hits the "&" corrector, then it should move one cell up and start extracting again until it hits the &, guessing it will be a For loop but because I dont know this language have no idea how to implement it, can someone please help me?

Thanks
Anshuman

 

[Sektor]

Sub A5()
    Dim x, j, arr
    For x = 1 To 5 Step 2
        arr = Split(Cells(x, 1), "&")
        For j = LBound(arr) To UBound(arr)
            Cells(x, j + 2) = Trim$(arr(j))
        Next
    Next
End Sub

 

[Sektor]

Or this way:

Sub A6()
    Dim x, arr
    For x = 1 To 5 Step 2
        arr = Split(Cells(x, 1), "&")
        Cells(x, 2).Resize(, UBound(arr) + 1) = arr
    Next
End Sub

 

[asgsitting]

thanks ever so much , it's working! but its extracting to B1 C1 D1 instead of B1 B2 B3...

 

[asgsitting]

Or this way:

Sub A6()
    Dim x, arr
    For x = 1 To 5 Step 2
        arr = Split(Cells(x, 1), "&")
        Cells(x, 2).Resize(, UBound(arr) + 1) = arr
    Next
End Sub

the above one is throwing an exception error..

 

[Sektor]

Sub A6()
    Dim x, arr
    For x = 1 To 5 Step 2
        arr = Split(Cells(x, 1), "&")
        Cells(x, 2).Resize(UBound(arr) + 1) = Application.Transpose(arr)
    Next
End Sub

 

[Ombir]

Assuming that you have input data in column A as shown below:

	A
Mr Adam Smith & Mrs Celia Smith
Dr I Gupta & Dr V Gupta & Mr A Gupta
Dr I Gupta & Dr V Gupta & Mr A Gupta
Mr A Ping & Mr Wa Chu

<colgroup><col style="width: 25pxpx"><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]

[TD="align: center"]2[/TD]

[TD="align: center"]3[/TD]

[TD="align: center"]4[/TD]

</tbody>

Sheet3​

Required output after automatically inserting required number of rows:

	A	B
Mr Adam Smith & Mrs Celia Smith	Mr Adam Smith
Mrs Celia Smith
Dr I Gupta & Dr V Gupta & Mr A Gupta	Dr I Gupta
Dr V Gupta
Mr A Gupta
Dr I Gupta & Dr V Gupta & Mr A Gupta	Dr I Gupta
Dr V Gupta
Mr A Gupta
Mr A Ping & Mr Wa Chu	Mr A Ping
Mr Wa Chu

<colgroup><col style="width: 25pxpx"><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]

[TD="align: center"]2[/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]

[TD="align: center"]4[/TD]
[TD="align: right"][/TD]

[TD="align: center"]5[/TD]
[TD="align: right"][/TD]

[TD="align: center"]6[/TD]

[TD="align: center"]7[/TD]
[TD="align: right"][/TD]

[TD="align: center"]8[/TD]
[TD="align: right"][/TD]

[TD="align: center"]9[/TD]

[TD="align: center"]10[/TD]
[TD="align: right"][/TD]

</tbody>

Sheet3
​

Hope this Code helps:

Sub anshuman()
Dim i As Long, j As Long, lr As Long, rw as long ,rins as integer
Dim name As Variant, rng As Range, nrng As Range
Dim ws As Worksheet
Dim txt as string

Set ws = Sheets("Sheet3")
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:A" & lr)

For Each Cell In rng
    j = j + Len(Cell) - Len(Replace(Cell, "&", ""))
Next

Set nrng = ws.Range("A1:A" & j + lr)

For Each Cell In nrng
    rw = Cell.Row
    If LenB(Cell) <> 0 Then
        txt = Cell.Text
        name = Split(txt, " & ")
        rins = UBound(name)
        Cell.Offset(1).Range("A1:A" & rins).Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Range("B" & rw).Resize(rins + 1) = Application.Transpose(name)
    End If
Next
End Sub

Regards,
Ombir