Parse

[jesmiki]

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
1xxxx-4-------ZHECXXXX1;FXXXX280XX;AXXXXC8818XX;CXXXXXC89X3
-----------------------------------------------------------------------

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

Cheers!

 

[xenou]

Hi,
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)
    
    '//parse
    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

 

[jesmiki]

Greetings Alexander,

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

Any ideas?

Cheers,

Carlo.

 

[facethegod]

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)
Next
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)
    Next
b(ii) = Empty
Loop
Next
Range("D1").Resize(x, 2) = c
End With
End Sub

 

[jesmiki]

Amazing thank you so much!

Thanks to you all that tried to help.....

Cheers!

Carlo.