Macro to Parse Column Values

Hi,

Thanks for your follow up.

Ron's code worked on the example data above, but not on the real data sets.

Your code worked on one of the real data sets but not the other. It stopped on line:

oneLabel = Trim(Left(mySplits(SLC), equalPoint - 1))

with error: 'Run-time error 5 - Invalid procedure call or argument'

Could i email you the data please, rather than posting it on a share site.

Many thanks & regards

Joyaz

Have you tried Ron's code to see if it does any better?

My code is dependent on (at least) 3 things:

That there are no empty cells in the list area.

That the Label#=Value? entries are all separated by a ; and that you don't just have a lonely semi-colon hanging out at the end without a Label=Value following it.

That the Label#=Value? entries all use the = symbol to separate the Label from the Value.

The exact error number and message it provides to you would most definitely be helpful in tracking it down.  Also, if you can, when the error message comes up, hit the Debug button and it will take you into the VB Editor showing the line of code where the error took place.  If you can copy that line of code and provide it also, a big help.  Once you've copied it, you can hit [F5] which will cause the same error to pop up again, then you can just [End] it to get out of the perpetual loop.  [Alt]+[Q] to close the VB Editor and return to the Excel worksheet.

Thank you so much - It works fine on one set of data, but gives a debug error on another set. I will come back with the error message, and the data.

Many Thanks

Joyaz

Here is a macro that should do what you want.  It assumes the original data starts in A1 and extends down that column.  For testing, it writes the results into E1; but if it works OK, you can change that to either overwrite the original, by setting it A1; or even put it on another worksheet.

I used regular expressions to obtain the different parts of each row (labels and values).

To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.

Ensure your project is highlighted in the Project Explorer window.

Then, from the top menu, select Insert/Module and

paste the code below into the window that opens.

To use this Macro (Sub), <alt-F8> opens the macro dialog box. Select the macro by name, and <RUN>.

======================================

Option Explicit

Sub ParseLabels()

    Dim vSrc As Variant

    Dim vRes() As Variant

    Dim vLabels As Variant

    Dim colLabels As Collection

    Dim re As Object, mc As Object, m As Object

    Dim I As Long, J As Long, lCOL As Long

    Dim S As String

    Dim rDest As Range

'rDest = destination for results

Set rDest = Range("E1")

'Get Source Data

vSrc = Range("a1", Cells(Rows.Count, "A").End(xlUp))

'Get list of Labels for Column Headers

Set re = CreateObject("vbscript.regexp")

With re

    .Global = True

    .MultiLine = True

    .Pattern = "(?:^|;\s*)([^=]+)"

End With

Set colLabels = New Collection

On Error Resume Next

    For I = 1 To UBound(vSrc)

        S = vSrc(I, 1)

        If re.test(S) = True Then

            Set mc = re.Execute(S)

            For Each m In mc

                colLabels.Add Item:=m.submatches(0), Key:=m.submatches(0)

            Next m

        End If

    Next I

On Error GoTo 0

'sort the labels except first

ReDim vLabels(1 To colLabels.Count)

For I = 2 To colLabels.Count

    vLabels(I) = colLabels(I)

Next I

Quick_Sort vLabels, 2, UBound(vLabels)

vLabels(1) = colLabels(1)

'set up results array

ReDim vRes(1 To UBound(vSrc), 1 To UBound(vLabels))

'write column Headers

For I = 1 To UBound(vLabels)

    vRes(1, I) = vLabels(I)

Next I

'write data

For I = 2 To UBound(vSrc)

    vRes(I, 1) = vSrc(I, 1)

    For J = 2 To UBound(vLabels)

        re.Pattern = vLabels(J) & "\s*=([^;]+?)\s*(?:;|$)"

        If re.test(vSrc(I, 1)) = True Then

            Set mc = re.Execute(vSrc(I, 1))

            lCOL = WorksheetFunction.Match(vLabels(J), vLabels, 0)

            vRes(I, lCOL) = mc(0).submatches(0)

        End If

    Next J

Next I

Set rDest = rDest.Resize(rowsize:=UBound(vRes), columnsize:=UBound(vRes, 2))

rDest.EntireColumn.Clear

rDest = vRes

rDest.EntireColumn.AutoFit

End Sub

Sub Quick_Sort(ByRef SortArray As Variant, ByVal first As Long, ByVal last As Long)

Dim Low As Long, High As Long

Dim Temp As Variant, List_Separator As Variant

Low = first

High = last

List_Separator = SortArray((first + last) / 2)

Do

    Do While (SortArray(Low) < List_Separator)

        Low = Low + 1

    Loop

    Do While (SortArray(High) > List_Separator)

        High = High - 1

    Loop

    If (Low <= High) Then

        Temp = SortArray(Low)

        SortArray(Low) = SortArray(High)

        SortArray(High) = Temp

        Low = Low + 1

        High = High - 1

    End If

Loop While (Low <= High)

If (first < High) Then Quick_Sort SortArray, first, High

If (Low < last) Then Quick_Sort SortArray, Low, last

End Sub

==================================

Try this code.  The sheet with the data entries on it must be selected when you run it.  It can be run from the [View] or [Developer] tab.

Here are the results I got:

Label A	Label1	Label2	Label3	Label4	Label5	Label6	Label8
Label1=Value1; Label2=Value2; Label4=Value4	Value1	Value2		Value4
Label2=Valuex; Label5=ValueY		Valuex			ValueY
Label1=Valuem; Label3=ValueN; Label6=ValueZ	Valuem		ValueN			ValueZ
Label2=ValueK; Label8=ValueP		ValueK					ValueP

.

Here is the code:

Sub SplitData()

'worksheet with data to be split must be selected when

'this macro is executed.

'

'See this web-site for instructions on putting this code

'into a Regular Code Module for use

' http://www.contextures.com/xlvba01.html#videoreg

'

  'change these 2 Const values if required.

  'hopefully it won't be - if not in column A, then

  'it's a whole different programming solution!

  'set this = column that the long terms are in

  Const dataCol = "A"

  'set this = 1st row with a long term to be examined

  Const firstDataRow = 2

  Dim listRange As Range

  Dim anyListEntry As Range

  Dim mySplits As Variant

  Dim equalPoint As Integer

  Dim oneLabel As String

  Dim oneValue As String

  Dim SLC As Integer

  Dim labelsList As Range

  Dim foundLabel As Range

  Dim newLabelCell As Range ' needed to position the value

  Application.ScreenUpdating = False ' improves performance

  Set listRange = Range(dataCol & firstDataRow & ":" _

   & Range(dataCol & Rows.Count).End(xlUp).Address)

  For Each anyListEntry In listRange

    mySplits = Split(anyListEntry, ";")

    For SLC = LBound(mySplits) To UBound(mySplits)

      equalPoint = InStr(mySplits(SLC), "=")

      oneLabel = Trim(Left(mySplits(SLC), equalPoint - 1))

      oneValue = Right(mySplits(SLC), Len(mySplits(SLC)) - equalPoint)

      Set labelsList = Range("A1:" & Cells(1, Columns.Count).End(xlToLeft).Address)

      Set foundLabel = labelsList.Find(what:=oneLabel, after:=Cells(1, 1), _

       LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False)

      If foundLabel Is Nothing Then

        'new label, add to the list in row 1

        Set newLabelCell = Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)

        newLabelCell = oneLabel

        Cells(anyListEntry.Row, newLabelCell.Column) = oneValue

      Else

        'existing label, copy the value under it

        Cells(anyListEntry.Row, foundLabel.Column) = oneValue

      End If

    Next ' end SLC loop

  Next ' end anyListEntry loop

  'now sort columns B:?? to get the labels in sequence along with their data

  'reuse listRange and labelsList for the sorting

  Set listRange = Range("B1:" & Cells(Range("A" & Rows.Count).End(xlUp).Row, _

   Cells(1, Columns.Count).End(xlToLeft).Column).Address)

  Set labelsList = Range("B1:" & Cells(1, Columns.Count).End(xlToLeft).Address)

  ActiveSheet.Sort.SortFields.Clear

  ActiveSheet.Sort.SortFields.Add Key:=labelsList, _

      SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

  With ActiveSheet.Sort

      .SetRange listRange

      .Header = xlNo

      .MatchCase = False

      .Orientation = xlLeftToRight

      .SortMethod = xlPinYin

      .Apply

  End With

  'good housekeeping

  Set listRange = Nothing

  Set labelsList = Nothing

  Set foundLabel = Nothing

End Sub