CODEWITHSUNDEEP
excelvba
warfo09
warfo09

Reputation: 157

VBA parsing through data

I have an Excel file with a column with rows in the following format:

{'gender': 'Male', 'national.': 'GBR', 'doc_type': 'passport', 'expiry': '2012-02-12', 'issuer': 'GBR'}

I would like to parse through the rows, say A1:A7, to extract it as a meaningful data like that, splitting it into multiple columns.

 A         B           C               D               E   
Gender   Nat         Doc_T           Date of Expiry   Issuer
Male     GBR         Passport       2012-02-12     GBR
Male     GBR         Passport       2012-02-12     GBR
Male     GBR         Passport       2012-02-12     GBR

I made a head start and wrote this code, however it piles all the data into one cell, I'm not sure how to split it further as above. Any help would be appreciated.

  Sub test3()
  Dim rng1 As Range
  Dim c As Range
  Set rng1 = Range("A1:A7")

  For Each c In rng1
   For Each e In Split(Replace(Replace(Replace(c, "'", ""), "{", ""), "}", ""), ",")
        x = Split(e, ":")
        temp = x(0): x(0) = x(1): x(1) = temp
        c.Value = c.Value & vbLf & Application.Trim(Join(x, " "))
    Next
  Next c

Produced Ouput with my code:

Male gender
GBRnationality
passport document_type
2012-02-12 date_of_expiry
GBR issuing_country

Any help would be appreciated, thank you!

Upvotes: 0

Views: 81

Answers (3)

Ron Rosenfeld
Ron Rosenfeld

Reputation: 60494

Since these entries are JSON strings, I would use a Json Parser. One that I like is by (c) Tim Hall

Then the code becomes:

Option Explicit
Sub parseJsonLine()
    Dim JSON As Object
    Dim ws As Worksheet, rSrc As Range, c As Range, r As Range
    Dim v, J As Long, O As Object

Set ws = Worksheets("sheet2")
With ws
    .Range(.Cells(1, 2), .Cells(1, 20)).EntireColumn.Clear
    Set rSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

For Each c In rSrc
    Set JSON = parsejson(c.Value2)
    If ws.Cells(1, 2).Value2 = "" Then
        v = JSON.Keys
        Set r = ws.Range(ws.Cells(1, 2), ws.Cells(1, UBound(v) + 2))
        r.Value2 = v
    End If
    J = 1
    For Each v In JSON
        J = J + 1
        c(2, J) = JSON(v)
    Next v
Next c

End Sub

And the results:

enter image description here

I put the results starting in Column B, but you could overwrite, or put them on a different worksheet, by changing some of the variables in the code.

Upvotes: 2

Nathan_Sav
Nathan_Sav

Reputation: 8531

I would suggest something along these lines:

Sub TestParseString()

Dim s As String

s = "{'gender': 'Male', 'nationality': 'GBR', 'document_type': 'passport', 'date_of_expiry': '2012-02-12', 'issuing_country': 'GBR'}"

ParseString s, Range("a1"), True
ParseString s, Range("a2")

End Sub

Sub ParseString(strInput As String, rngOutput As Range, _
                Optional blnHeaders = False)

Dim s2 As String
Dim a() As String
Dim l As Long

strInput = Replace(Replace(strInput, "{", ""), "}", "")
a = Split(strInput, ",")

For l = 0 To UBound(a)

    If blnHeaders Then
        s2 = Trim(Replace(Split(a(l), ":")(0), "'", ""))
        rngOutput.Offset(0, l).value = s2
    End If

    s2 = Trim(Replace(Split(a(l), ":")(1), "'", ""))
    rngOutput.Offset(Abs(blnHeaders), l).value = s2

Next l


End Sub

Upvotes: 1

Pᴇʜ
Pᴇʜ

Reputation: 57753

  1. Strip off the brackets {}
  2. Split by , to get the data pairs into an array DataPairs.
  3. Loop through that array and split each data pair by :.
  4. Finally strip off the '' of the data and write it into the cells.

So something like this should work:

Option Explicit

Public Sub ParseData()
    Dim RawData As String
    RawData = "{'gender': 'Male', 'nationality': 'GBR', 'document_type': 'passport', 'date_of_expiry': '2012-02-12', 'issuing_country': 'GBR'}"

    Dim wsOutput As Worksheet
    Set wsOutput = ThisWorkbook.Worksheets("Sheet1")

    Dim NextFreeRow As Long
    NextFreeRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row + 1

    'strip off {}
    RawData = Mid$(RawData, 2, Len(RawData) - 2)

    Dim DataPairs() As String
    DataPairs = Split(RawData, ", ")

    Dim iPair As Long
    For iPair = LBound(DataPairs) To UBound(DataPairs)
        Dim FieldData() As String
        FieldData = Split(DataPairs(iPair), ": ")

        wsOutput.Cells(NextFreeRow, iPair + 1).Value = Mid$(FieldData(1), 2, Len(FieldData(1)) - 2) 'strip of '' and write to cell
    Next iPair
End Sub

enter image description here

Finally you will figure out how to get the headlines too.

Upvotes: 1

Related Questions