[Adodb.Stream] json 파일로 추출하기

Option Base 1
 
Sub Macro()
 
    Dim ADOStream As Object
    Dim UnitData As Range
    Dim SingleRange As Range
    Dim v() As String
    Dim i As Integer
    Dim ColumnsCount As Integer
    
    Set UnitData = Range("A8", Cells(Rows.Count, "A").End(3))   '추출할 데이터 영역(A열)
    ColumnsCount = Range("A5").CurrentRegion.Columns.Count  '열 개수
    ReDim v(ColumnsCount)   '열개수에 맞게 재배열
    
    Set ADOStream = CreateObject("ADODB.Stream")    'ADODB.Stream 개체생성
    With ADOStream  'ADOStream 설정
        .Open
        .Charset = "UTF-8"
        .Type = 2
        .writetext "[" & vbLf   ''첫 대괄호 입력
    End With
    
    For Each SingleRange In UnitData    '데이터영역 순환
        
        'A열부터 마지막열까지 순환하면서
        '문자는 앞뒤로 " 를 붙여주고 숫자는 "를 붙이지 않은 채 배열에 삽입
        For i = 1 To ColumnsCount
            v(i) = """" & Cells(6, SingleRange.Offset(, i - 1).Column) & """:" & CheckNumber(SingleRange.Offset(, i - 1))
        Next i
        
        ADOStream.writetext "{" & Join(v, ",") & "}" & vbLf '앞뒤로 {} 를 붙여줌
        
    Next SingleRange
    
    Erase v '배열 초기화
            
    With ADOStream
        .writetext "]"  '맨 마지막에 ] 삽입
        .SaveToFile ThisWorkbook.Path & "\tmp.json", 2  '파일 성
        .Close  'ADOStream 닫기
    End With
    
    MsgBox "추출성공"
    
End Sub
 
Function CheckNumber(SingleData As String) As String
 
    Select Case IsNumeric(SingleData)
        
        Case True
            CheckNumber = SingleData
        
        Case False
            CheckNumber = """" & SingleData & """"
            
    End Select
 
End Function
 
 

json.xls