VBA анализирует данные

Question

У меня есть файл Excel со столбцом со строками в следующем формате:

{'пол': 'мужской', 'национальный.': 'GBR', 'doc_type': ' паспорт ',' срок действия ':' 2012-02-12 ',' эмитент ':' GBR '}

Я хотел бы проанализировать строки, скажем, A1: A7, чтобы извлечь их как такие значимые данные, разбив их на несколько столбцов.

 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

Я сделал первый шаг и написал этот код, однако он собирает все данные в одну ячейку, я не уверен, как разбить их далее как выше. Любая помощь будет оценена.

  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

Произведено Ouput с моим кодом:

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

Любая помощь будет оценена, спасибо!

Answer 1

Поскольку эти записи являются JSON строками, я бы использовал Json Parser. Тот, который мне нравится, это (c) Тим Холл

Тогда код становится:

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

И результаты:

Я поместил результаты, начиная с столбца B, но вы можете перезаписать или поместить их на другой лист, изменив некоторые переменные в коде.

Answer 2

Я бы предложил что-то вроде этого:

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

Answer 3

1. Снять скобки {}
2. Разделить на ,, чтобы получить пары данных в массив DataPairs.
3. L oop через этот массив и разделите каждую пару данных на :.
4. Наконец снимите '' данных и запишите их в ячейки.

Так что-то вроде этого должно работать:

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

Наконец, вы поймете, как получить заголовки тоже.