[VBA] JSON 을 이름, 값 배열로 변환하기 (JSONPair)

구글 캘린더나 다른 API 작업을 할 때, 결과가 xml 아닌 json으로 출력되는 경우

그 동안에는 JSON converter를 사용하고 있었습니다.

 

이를 VBA에서 쉽게 사용할 수 있는 배열로 변환하고 이를 바탕으로 이름 경로(Path)를 이용하여 값이나 목록을 출력하도록 설계를 했습니다.  여기서는 먼저 배열로 변환하는 함수를 설명합니다.

 

【 함수 구문 】

= JSONPair(  JSON ,   [ Delimiter ]  )

 

【 함수 인수 】

인수명	옵션	기본값	설    명
JSON	필수	없음	JSON 텍스트, 배열 또는 범위
Delimiter	선택	"/"	"이름 경로" 각 단계를 연결할 구분자, 기본값은 "/"

 

 

JSON 문자열을 하나씩 읽어서 그에 따른 처리를 진행하는 구조입니다.

 

공백문자를 Skip하기 위한 함수를 하나 작성합니다.

inDQ는 쌍따옴표 안인지 표시하는 변수로,  쌍따옴표 밖의 모든 공백과 줄넘김/탭을 모두 무시하고 idx를 이동 합니다.

Private Function NextIdx(ByRef JSON, ByVal idx&, inDQ)
    Do While idx < Len(JSON) And InStr(IIf(inDQ, "", " ") & vbCr & vbLf & vbTab, Mid(JSON, idx + 1, 1)) > 0
        idx = idx + 1
        If idx > Len(JSON) Then NextIdx = idx: Exit Do
    Loop
    NextIdx = idx + 1
End Function

 

 

JSON을 구성하는 "{", "}", "[", "]", ",", ":"  문자를 기준으로 처리하는데, 앞/뒤의 글자에 따라 처리 방향이 달라지므로 이를 구하는 데, 이전 글자는 사용후 저장하면 되고, 이후 문자는 공백처리에 따라 별도 함수로 구합니다.

Private Function NextChar(ByRef JSON, ByVal idx&)
    Do While InStr(" " & vbCr & vbLf & vbTab, Mid(JSON, idx + 1, 1)) > 0
        idx = idx + 1
        If idx > Len(JSON) Then NextChar = "": Exit Function
    Loop
    NextChar = Mid(JSON, idx + 1, 1)
End Function

 

 

배열에 임시저장한 버퍼문자열을 결과로 저장할 때, 임시 버퍼가 이름인지 값인지 구분하는 함수입니다.

Private Function isName(ByRef JSON, ByVal idx&, inDQ)
    Dim X$, in_DQ As Boolean
    in_DQ = inDQ
    If Mid(JSON, idx, 1) = """" Then idx = idx + 1
    X = Mid(JSON, idx, 1)
    If X = """" Then in_DQ = Not in_DQ
    Do
        If Not in_DQ Then
            If X = ":" Then isName = True: Exit Function
            If InStr("{[,]}", X) > 0 Then isName = False: Exit Function
        End If
        idx = idx + 1
        If idx > Len(JSON) Then isName = False: Exit Function
        X = Mid(JSON, idx, 1)
        If X = """" Then in_DQ = Not in_DQ
    Loop
    isName = X = ":"
End Function

 

배열의 크기를 변경하는 ResizeArray 함수입니다.  Redim은 열방향만 조정이 가능하여 행방향도 가능하도록 별도로 제작합니다.  배열 복사를 하나씩 하므로 속도 때문에 적절히 큰 배열을 사용하고, 코드 진행중에는 필요한 경우에만 변경,
맨 마지막에 실제 결과 크기로 최종 조정하는 데 사용합니다.

Private Function ResizeArray(srcArray As Variant, Rows As Long, Cols As Long)
    Dim NewArr, r&, c&, lbR&, ubR&, lbC&, ubC&, iD&
    
    iD = getDimension(srcArray)
    If iD <> 2 Then ResizeArray = CVErr(xlErrRef): Exit Function
    If Rows < 1 Or Cols < 1 Then ResizeArray = CVErr(xlErrValue): Exit Function
    
    lbR = LBound(srcArray, 1):    ubR = UBound(srcArray, 1)
    lbC = LBound(srcArray, 2):    ubC = UBound(srcArray, 2)
    
        ReDim NewArr(lbR To lbR + Rows - 1, lbC To lbC + Cols - 1)
        For r = lbR To UBound(NewArr, 1)
            For c = lbC To UBound(NewArr, 2)
                If r <= ubR And c <= ubC Then
                    NewArr(r, c) = srcArray(r, c)
                Else
                    NewArr(r, c) = Empty
                End If
            Next
        Next
        ResizeArray = NewArr

End Function

Private Function getDimension(var As Variant) As Long
    Dim i&, tmp&
    On Error GoTo Err
    Do While True
        i = i + 1
        tmp = UBound(var, i)
    Loop
Err:
    getDimension = i - 1
End Function

 

 

이제 JSON을 배열로 변경하는 최종 함수는 아래와 같습니다.

중간에 자주 사용하게 되는 부분은 GoSub를 이용하여 Label로 이동한 다음 Return으로 원 위치로 돌아갑니다.

Function JSONpair(JSON, Optional Delimiter$ = "/")
'======================================================================================================
' Name        JSONpair
' Version     v3r0      2024-03-28      EGTools(egexcelvba@gmail.com)
' Param       JSON      JSON text, Array or Range
'             Delimiter "이름 경로" 각 단계를 연결할 구분자, 기본값은 "/"
' Descripton  JSON text를 "이름 경로"와 "값"으로 구성된 배열로 변환
'             첫번째 열에 "이름 경로", 두번째 열에 "값"
'             "값"은 number/True/False 외의 문자열은 쌍따옴표로 표시됨 (JSON value 그대로)
'             목록('['과 ']'사용)에는 각 목록을 구분하기 위해 빈 행이 삽입됨
'======================================================================================================
    Dim Text$, idx&, sBuf$, iLvl&, iR&, iC&, iCnt&, vD, vValue, vH, vLvl, vList, X$, P$, N$, vItem, vResult
    Dim bName As Boolean, bVal As Boolean, inDQ As Boolean, BlankRow As Boolean, ArrayStart As Boolean
    
    '// 셀에 저장 가능한 글자수가 32767자로 TEXTJOIN을 사용해도 한계를 넘지 못하므로
    '// Range로 받아서 값을 VBA String 변수에 연결해 넣도록 함
    If TypeName(JSON) = "Range" Then
        If JSON.Cells.Count = 1 Then
            ReDim vD(0):        vD(0) = JSON.Value2
        Else
            vD = JSON.Value2
        End If
    ElseIf IsArray(JSON) Then
        vD = JSON
    Else
        ReDim vD(0):        vD(0) = JSON
    End If
    
    For Each vItem In vD: Text = Text & vItem: Next
    
    '// 배열을 충분히 크게 해주고 작업을 하는 것이 속도에 매우 중요함
    iCnt = Len(Text) - Len(Replace(Replace(Replace(Text, "{", ""), "[", ""), ",", ""))
    ReDim vD(1 To iCnt, 1 To 100) '// 처음에 크게 했다가 마지막에 ResizeArray로 조정
    ReDim vValue(1 To iCnt, 1 To 1)  '// 값을 별도로 기재하기 위해 사용
    ReDim vLvl(1 To 100)            '// 이름경로의 단계를 저장하기 위한 배열
    ReDim vList(1 To 100)           '// 배열이 사용된 위치를 표시하기 위한 배열
    ReDim vH(1 To 1)                '// 현재 이름 경로를 저장하는 배열
    iR = 1
    idx = NextIdx(Text, idx, inDQ)  '// 공백을 Skip
    
    If InStr("{[", Mid(Text, idx, 1)) = 0 Then    '// Object나 Array가 아닌 경우
        ReDim vD(1 To 1, 1 To 1): vD(1, 1) = Text: JSONpair = vD: Exit Function
    End If
    
    Do While idx <= Len(Text)
        X = Mid(Text, idx, 1)
        Select Case X
        Case "{"                    '// 개체 시작, Level을 증가
            If inDQ And bVal Then sBuf = sBuf & X: GoTo NEXT_IDX
            If P <> "[" And P <> ":" Then GoSub ADD_COL
            iLvl = iLvl + 1
            vLvl(iLvl) = iC
        Case "}"                    '// 개체 종료, Level을 축소
            If inDQ And bVal Then sBuf = sBuf & X: GoTo NEXT_IDX
            If sBuf <> "" Then GoSub WRITE_BUF
            iLvl = iLvl - 1:
            If iLvl = 0 Then iR = iR + 1: Exit Do                  'Exit Function
            iC = vLvl(iLvl)
            ReDim Preserve vH(1 To iLvl)
            If InStr("]}", P) = 0 Then GoSub ADD_ROW
        Case "["                    '// 배열 시작, Level은 유지, 배열안에 배열도 가능
            If inDQ And bVal Then sBuf = sBuf & X: GoTo NEXT_IDX
            If iLvl = 0 Then iLvl = iLvl + 1: vLvl(iLvl) = 1: iC = 1: ArrayStart = True
            vList(iLvl) = iLvl
            If P <> "{" And P <> ":" Then GoSub ADD_COL
        Case "]"                    '// 배열 종료, 버퍼 쓰기 필요
            If inDQ And bVal Then sBuf = sBuf & X: GoTo NEXT_IDX
            If InStr("}]", P) = 0 Then GoSub WRITE_BUF
            If InStr("}]", P) = 0 And InStr(",}]", NextChar(Text, idx)) Then GoSub ADD_ROW
            If ArrayStart And Trim(Join(Application.Index(vD, iR), "")) = Trim(Join(vH, "")) Then iR = iR - 1
        Case ":"                    '// 이름 구분자, 버퍼 쓰기 필요. 쌍따옴표 안은 버퍼에 추가
            If inDQ Then sBuf = sBuf & X: GoTo NEXT_IDX
            GoSub WRITE_BUF
            GoSub ADD_COL
        Case ","                    '// 값 구분자, 앞글자에 따라 또는 값 위치에서 버퍼 쓰기, 배열의 요소 변경시 구분할 수 있는 행 추가
            If inDQ And bVal Then sBuf = sBuf & X: GoTo NEXT_IDX
            If P = "]" Or P = "}" Then bName = True: bVal = False
            If P <> "}" And P <> "]" Then
                GoSub WRITE_BUF
                GoSub ADD_ROW
            ElseIf bVal Then
                GoSub WRITE_BUF
                GoSub ADD_ROW
            End If
            If vList(iLvl) = vLvl(iLvl) And NextChar(Text, idx) = "{" Then BlankRow = True: GoSub ADD_ROW

        Case """"                   '// 쌍따옴표 In/Out을 변경, 값에는 쌍따옴표를 그대로 사용
            inDQ = Not inDQ
            If Not isName(Text, idx, inDQ) Then sBuf = sBuf & X: GoTo NEXT_IDX
        Case "\"                    '// Escape 문자 처리
            N = NextChar(Text, idx)
            If N = """" Then sBuf = sBuf & """":      idx = idx + 1     '// Quotation Mark
            If N = "\" Then sBuf = sBuf & "\":        idx = idx + 1     '// Reverse Solidus
            If N = "/" Then sBuf = sBuf & "/":        idx = idx + 1     '// Solidus
            If N = "b" Then sBuf = sBuf & vbBack:     idx = idx + 1     '// Backspace
            If N = "f" Then sBuf = sBuf & vbFormFeed: idx = idx + 1     '// Form Feed
            If N = "n" Then sBuf = sBuf & vbLf:       idx = idx + 1     '// Line Feed or New Line
            If N = "r" Then sBuf = sBuf & vbCr:       idx = idx + 1     '// Carriage Return
            If N = "t" Then sBuf = sBuf & vbTab:      idx = idx + 1     '// Horizontal Tab
            If N = "u" Then sBuf = sBuf & ChrW(Application.Hex2Dec(Mid(Text, idx + 2, 4))): idx = idx + 5 '// Unicode
        Case Chr(7)
            sBuf = sBuf & "(Bell)"
        Case Else                   '// 나머지 일반 문자는 버퍼에 추가
            sBuf = sBuf & X
        End Select
        
NEXT_IDX:
        P = X
        idx = NextIdx(Text, idx, inDQ)
    Loop
    
    '// 최종크기로 배열 조정, 목록형 줄바꿈에 의한 끝부분 빈줄도 삭제
    If iR > UBound(vD, 1) Then iR = UBound(vD, 1)
    If Trim(Join(Application.Index(vD, iR), "")) = "" Then iR = iR - 1
    vItem = Application.Index(vD, iR)
    If Trim(Join(vItem, "")) = "" Then iR = iR - 1
    vD = ResizeArray(vD, iR, Application.Max(vLvl) + 1)
    vValue = ResizeArray(vValue, iR, 1)
    
    If Delimiter = vbNullChar Then Delimiter = Chr(7)
    
    ReDim vResult(1 To iR, 1 To 2)
    For iR = 1 To UBound(vD, 1)
        For iC = 1 To UBound(vD, 2) - 1
            vItem = vD(iR, iC): GoSub REMOVE_DQ
            If vItem <> "" Then vResult(iR, 1) = vResult(iR, 1) & IIf(IsEmpty(vResult(iR, 1)), "", Chr(7)) & vItem
        Next iC
        If Delimiter <> Chr(7) Then vResult(iR, 1) = Replace(vResult(iR, 1), Chr(7), Delimiter)
        vResult(iR, 2) = vValue(iR, 1)
    Next iR
    
    JSONpair = vResult
    Exit Function
    
'========= GoSub Labels =========================================================
    
WRITE_BUF:                          '// 쓰려는 값이 이름인지 값인지 확인하여 처리
    bName = isName(Text, idx, inDQ)
    If bName Then
        ReDim Preserve vH(1 To iLvl)
        For iCnt = 1 To iLvl - 1
            vD(iR, iCnt) = vH(iCnt)
        Next iCnt
        vH(iLvl) = sBuf
        vD(iR, vLvl(iLvl)) = sBuf
        bName = False
        bVal = True
        
    Else
        If iLvl <= UBound(vH) Then  '// {}처럼 공갈 개체가 있는 경우 오류 방지
          For iCnt = 1 To iLvl - 1
              vD(iR, iCnt) = vH(iCnt)
          Next iCnt
          vD(iR, vLvl(iLvl)) = vH(iLvl)
          vValue(iR, 1) = sBuf
        End If
    End If
    sBuf = ""
    iC = vLvl(iLvl)
    Return
    
ADD_COL:                            '// 열증가, 배열보다 크면 크기 조정
    iC = iC + 1
    If iC > UBound(vD, 2) Then GoSub RESIZE
    Return
    
ADD_ROW:                            '// 행증가, 배열보다 크면 크기 조정, + 좌측 이름경로 입력
    iR = iR + 1
    If iR > UBound(vD, 1) Then GoSub RESIZE
    For iCnt = 1 To UBound(vD, 2)
        If BlankRow Then            '// 목록의 요소간 구분시 첫번째 칸에만 vbNullChar -> 구분행 기준
            If iCnt = 1 Then vD(iR - 1, iCnt) = vbNullChar Else vD(iR - 1, iCnt) = Empty
        End If
    Next iCnt
    BlankRow = False
    Return

RESIZE:
    vD = ResizeArray(vD, Application.Max(iR, UBound(vD, 1)), Application.Max(iC, UBound(vD, 2)))
    vValue = ResizeArray(vValue, Application.Max(iR, UBound(vValue, 1)), 1)
    Return
        
REMOVE_DQ:
    If vItem <> """""" Then       '// 값 자체가 ""인 경우에는 쌍따옴표 제거 예외시킴
        If Left(vItem, 1) = """" Then vItem = Mid(vItem, 2)
        If Right(vItem, 1) = """" Then vItem = Left(vItem, Len(vItem) - 1)
    End If
    Return
        
End Function

 

 

다음은 이 함수를 이용하여 이름경로 배열을 확장하는  JSONtoArray 함수와,
이름 경로를 검색하여 결과를 표로 출력하는  JSONParse 함수를 작업합니다.