New Member
Mar 4, 2009
Greetings All,

I have a problem and hope someone can assist. I have a excel workbook that looks like paradigm (i).

Unfortuneately, the uniquie IDs in column (A) need to go with the cell in corresponding cell (B), which has data combined together in one cell seperated by a ;

Is there a way, in excel that I can run a macro to have the data look like paradigm (ii)?

Paradigm (i)
A --------------B

Paradigm (ii)
A -------------------------> B
1xxxx-4 -------------------> ZHECXXXX1
1xxxx-4 - -----------------> FXXXX280XX
1xxxx-4 -------------------> AXXXXC8818XX
1xxxx-4 ------------------> CXXXXXC89X3


Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
Try this macro.

I hope it works! You will be prompted to select the cell with the first value where this starts. It will parse all the cells below it and in the column to the right. Output is to a new sheet.

To load a macro (XL 2003):
1) Right click the sheet tab;
2) From the main menu in the vbe window choose Insert | Module
3) Paste this code into the module window.
4) close the VBE window
5) Under the main Excel menu choose Tools | Macros | Macro... and select this macro named "Parse_Cells"
6) You will also find help at microsoft office online searching for "run a macro"

Sub Parse_Cells()
Dim a
Dim b
Dim c()
Dim r As Range
Dim lr As Range
Dim lngCount As Long, i As Long, j As Long, ans As Integer
Dim ws As Worksheet
Dim wsDest As Worksheet

'//sheet with original data
Set ws = ActiveSheet

'//escape hatch
ans = MsgBox("Macro changes cannot be reversed. Are you sure you want to continue?", vbYesNo)
If ans <> vbYes Then Exit Sub

With ws
    '//user will input cell where first row of data to parse starts
    Set r = GetTopLeftCell()
    If r Is Nothing Then Exit Sub '//user cancelled
    Set lr = Cells(Rows.Count, r.Column).End(xlUp)
    '//load values into an array and dim output array
    a = .Range(r, lr.Offset(0, 1)).Value
    ReDim c(1 To 2, 1 To 1)
    lngCount = 1
    '//loop through column 1
    For i = LBound(a, 1) To UBound(a, 1)
        '//split out semi-colon delimited values in column 2
        b = Split(a(i, 2), ";", -1, vbTextCompare)
        For j = LBound(b) To UBound(b)
            '//load into array for output
            ReDim Preserve c(1 To 2, 1 To lngCount)
            c(1, lngCount) = a(i, 1)
            c(2, lngCount) = b(j)
            lngCount = lngCount + 1
        Next j
    Next i

End With

'//write values to new workbook/worksheet
Workbooks.Add.Worksheets(1).Cells(1, 1).Resize(UBound(c, 2), 2).Value = WorksheetFunction.Transpose(c)

End Sub
Function GetTopLeftCell() As Range
'//Get input range from user
On Error Resume Next
Set GetTopLeftCell = Application.InputBox(Prompt:="Select Top Left Cell where Data begins", Type:=8)
End Function
Upvote 0
Greetings Alexander,

Thank you for the response; nevertheless, when I run the code, it opens a new workbook and its blank.

Any ideas?


Upvote 0
Or try...

Option Explicit
Sub tst()
Dim ac As New Collection, i As Integer, ii As Integer, x As Integer, r As Range, iii As Integer
Dim a, b(), c() As String, d() As String
With Application
Set r = Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row): a = r
ReDim b(1 To UBound(a, 1))
ReDim c(1 To Rows.Count, 1 To 2)
For i = 1 To UBound(a, 1)
    On Error Resume Next
    ac.Add a(i, 1), CStr(a(i, 1))
    b(i) = a(i, 1)
On Error GoTo 0
For i = 1 To ac.Count
Do Until IsError(.Match(ac.Item(i), b, 0))
ii = .Match(ac.Item(i), b, 0)
d = Split(a(ii, 2), ";")
    For iii = 0 To UBound(d)
    x = x + 1: c(x, 1) = ac.Item(i): c(x, 2) = d(iii)
b(ii) = Empty
Range("D1").Resize(x, 2) = c
End With
End Sub
Upvote 0

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back