살아가는 이야기

유니티 프로젝트를 진행하며 엑셀 데이터를 바이너리로 만들어야 하는 경우가 발생

클라이언트 분이 만들어 주시긴 하지만

유니티 켜기가 싫다!!

만들자!!

Public Const strTitle = "noti"          '박스 타이틀
Public Const msgCellsErr = " 셀에 오류가 있어 데이터 생성을 중단합니다."
Public Const msgNotDataSheet = "데이터 시트 테이블이 아니어서 프로세스를 종료합니다."

Option Explicit
' CodePage constant for UTF-8
Private Const CP_UTF8 = 65001

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (hpvDest As Any, _
    hpvSource As Any, _
    ByVal cbCopy As LongPtr)

'utf8 변환
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As LongPtr, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As LongPtr, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long) As Long

Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpMultiByteStr As LongPtr, _
    ByVal cchMultiByte As Long, _
    ByVal lpWideCharStr As LongPtr, _
    ByVal cchWideChar As Long _
    ) As Long
#Else

    Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

'utf8 변환
    Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
        ByVal CodePage As Long, _
        ByVal dwFlags As Long, _
        ByVal lpWideCharStr As Long, _
        ByVal cchWideChar As Long, _
        ByVal lpMultiByteStr As Long, _
        ByVal cbMultiByte As Long, _
        ByVal lpDefaultChar As Long, _
        ByVal lpUsedDefaultChar As Long _
        ) As Long
#End If


'바이트로 변환을 위해 각 타입별로 바이트 변수 지정
Private Type ByteLong
    value(3) As Byte
End Type
 
Private Type TypedLong
    value As Long
End Type

Private Type ByteByte
    value(0) As Byte
End Type

Private Type TypedByte
    value As Byte
End Type

'타입별로 바이트 array 로 변환하는 펑션
Function LongToByteArray(ByVal value As Long) As Byte()
      'Purpose: Converts a variable of the type Long to a byte array.
    Dim tlJump As TypedLong
    Dim blJump As ByteLong
    tlJump.value = value
    LSet blJump = tlJump
    LongToByteArray = blJump.value
End Function


Function ByteToByteArray(ByVal value As Long) As Byte()
      'Purpose: Converts a variable of the type Long to a byte array.
    Dim tlJump As TypedByte
    Dim blJump As ByteByte
    tlJump.value = value
    LSet blJump = tlJump
    ByteToByteArray = blJump.value
End Function



Function SingToByte(ByVal D As Single) As Byte()
    Dim Bytes(LenB(D) - 1) As Byte
    Dim I As Integer
    Dim S As String
    CopyMemory Bytes(0), D, LenB(D)
    For I = 0 To UBound(Bytes)
        S = S & CStr(Bytes(I)) & " "
    Next
    SingToByte = Bytes
End Function


Sub bytes_export_Click(control As IRibbonControl) 'bytes Export 버튼 클릭시 실행될 내용

    Call CDataD

End Sub

Sub bytes_Allexport_Click(control As IRibbonControl) 'All bytes Export 버튼 클릭시 실행될 내용
    Dim sht As Worksheet

    For Each sht In Worksheets
        If sht.Name <> "info" Then
            Call CreateData(sht.Name, 1)
        End If
    Next sht
    
    MsgBox ThisWorkbook.Path & "\" & "bytes" & "\" & Chr(10) & "데이터 익스포트 완료", Title:=strTitle
End Sub



'어....어디서 가져왔더라...여튼 바이트를 utf8 변환하는 코드

'utf8 변환
Public Function Utf8BytesFromString(strInput As String) As Byte()
    Dim nBytes As Long
    Dim abBuffer() As Byte
    ' Catch empty or null input string
    Utf8BytesFromString = vbNullString
    If Len(strInput) < 1 Then Exit Function
    ' Get length in bytes *including* terminating null
    nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, 0&, 0&, 0&, 0&)
    ' We don't want the terminating null in our byte array, so ask for `nBytes-1` bytes
    ReDim abBuffer(nBytes - 2)  ' NB ReDim with one less byte than you need
    nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, ByVal VarPtr(abBuffer(0)), nBytes - 1, 0&, 0&)
    Utf8BytesFromString = abBuffer
End Function
''' Return length of byte array or zero if uninitialized

'utf8 관련
Private Function BytesLength(abBytes() As Byte) As Long
    ' Trap error if array is uninitialized
    On Error Resume Next
    BytesLength = UBound(abBytes) - LBound(abBytes) + 1
End Function

''' Return VBA "Unicode" string from byte array encoded in UTF-8
Public Function Utf8BytesToString(abUtf8Array() As Byte) As String
    Dim nBytes As Long
    Dim nChars As Long
    Dim strOut As String
    Utf8BytesToString = ""
    ' Catch uninitialized input array
    nBytes = BytesLength(abUtf8Array)
    If nBytes <= 0 Then Exit Function
    ' Get number of characters in output string
    nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, 0&, 0&)
    ' Dimension output buffer to receive string
    strOut = String(nChars, 0)
    nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, StrPtr(strOut), nChars)
    Utf8BytesToString = Left$(strOut, nChars)
End Function

'중복키값체크

Sub checkDulpicatePrimarykey(str_SheetName As String)
    
    On Error Resume Next

    Dim int_CNT As Long
    Dim int_Temp As Integer
    Dim I, j As Integer
    
    int_CNT = Application.CountA(Worksheets(str_SheetName).Range("A:A"))
    
    Uf_status.Show
    Uf_status.Caption = "PrimaryKey 중복 체크 중"
    
    For I = 4 To int_CNT
        
        '기본 키 비교
        
        int_Temp = Application.CountIfs(Worksheets(str_SheetName).Range("A:A"), Worksheets(str_SheetName).Cells(I, 1) & "*", Worksheets(str_SheetName).Range("A:A"), Worksheets(str_SheetName).Cells(I, 1))
            
        If int_Temp > 1 Then

            MsgBox Worksheets(str_SheetName).Name & " 시트 " & I & " 열의 ID 가 중복됩니다." & Chr(10) & Chr(34) & Cells(I, 1) & Chr(34), Title:=strTitle
            Unload Uf_status
            Exit Sub

        End If

        Uf_status.lbl_status.Width = 210 / int_CNT * I
        Uf_status.lbl_status_string = Int(I / int_CNT * 100) & " % " & "(" & I & "/" & int_CNT & ")"
        Uf_status.Repaint
    
    Next I
    
    Unload Uf_status
    
End Sub

'헤더체크

Sub checkDulpicateHeader(str_SheetName As String) '헤더 중복 체크
    
    Dim int_CNT As Long
    Dim int_Temp As Integer
    Dim I, j As Integer
    
    Uf_status.Show
    Uf_status.Caption = "필드명 중복 체크 중"

    int_CNT = Application.CountA(ActiveSheet.Range("3:3"))
    
    For I = 1 To int_CNT
    
        '내부 사용을 위해 기울임꼴 처리된 항목 배제
        If ActiveSheet.Cells(3, I).Font.FontStyle = "기울임꼴" Or ActiveSheet.Cells(3, I).Font.FontStyle = "굵은 기울임꼴" Then
        
        Else
    
            int_Temp = Application.CountIf(Range("3:3"), Cells(3, I))
    
            If int_Temp > 1 Then
    
                MsgBox Worksheets(str_SheetName).Name & " 시트 " & I & " 행의 이름이 중복됩니다." & Chr(10) & Chr(34) & Worksheets(str_SheetName).Cells(3, I) & Chr(34), Title:=strTitle
                Unload Uf_status
                Exit Sub
    
            End If
    
            Uf_status.lbl_status.Width = 210 / int_CNT * I
            Uf_status.lbl_status_string = Int(I / int_CNT * 100) & " % " & "(" & I & "/" & int_CNT & ")"
            Uf_status.Repaint
    
        End If
                
    Next I
    
    Unload Uf_status

End Sub

실제 데이터 찍는곳
Sub CDataD()

Dim str_TempRng As String
    
    '시트이름에 data_ 가 없으면 데이터 테이블 시트가 아닌 경우 종료
    'If UCase(Left(ActiveSheet.Name, 5)) = "DATA_" Then
    If ActiveSheet.Name <> "info" Then
        str_TempRng = DetectErr(ActiveSheet.Name)
        
        If str_TempRng <> "" Then
            MsgBox str_TempRng & msgCellsErr, Title:=strTitle
            GoTo Err
        End If
            '별도 프로시저를 호출
            Call CreateData(ActiveSheet.Name, 0)
        Exit Sub

        Else
            MsgBox msgNotDataSheet, Title:=strTitle
    End If
    
Err:
End Sub
'에러 발생시 오류 메시지 출력
Function DetectErr(str_SName As String)

    Dim rng_Temp As Object

    On Error Resume Next

    Set rng_Temp = Worksheets(str_SName).Cells.SpecialCells(xlCellTypeFormulas, 16)

    If rng_Temp Is Nothing Then
    
    
    Else
    
        DetectErr = Worksheets(str_SName).Cells.SpecialCells(xlCellTypeFormulas, 16).Address
    
    End If

    Set rng_Temp = Worksheets(str_SName).Cells.SpecialCells(xlCellTypeConstants, 16)
    
    If rng_Temp Is Nothing Then
    
    
    Else
    
        DetectErr = DetectErr + Worksheets(str_SName).Cells.SpecialCells(xlCellTypeConstants, 16).Address
    
    End If

End Function

' 한글 완성형 문자열의 바이트 수 구하기 함수
Function LenMbcs(ByVal str As String)
  LenMbcs = LenB(StrConv(str, vbFromUnicode))
End Function

'실제 시트 데이터 반복 부분
Sub CreateData(str_SheetName As String, ci As Integer)
    
    

    Dim str_Path As String

    Dim str_sSheetName As String
    Dim byteName As String

    Dim int_NFields As Integer
    Dim int_NData, var_Tempindex As Long
    
    Dim I, j As Long '셀 반복
    
    Dim Body As Object
    
    Dim var_TempType, var_TempValue
    Dim var_TempLong As Long

    Dim var_TempString As String
    Dim var_Tempbyte() As Byte
    Dim var_Tempbyte2 As Byte
    Dim var_TempPrebyte() As Byte
    Dim var_TempFloat As Single
    Dim str_workPath As String
    Dim ck_dir As Boolean
    
    

    '중복키값 체크
    Call checkDulpicatePrimarykey(str_SheetName)
    Call checkDulpicateHeader(str_SheetName)

   ' 저장 폴더 존재 여부 체크 후 없다면 생성
   If Dir("D:\work\DataTables\", vbDirectory) = "" Then
        If Dir(ThisWorkbook.Path & "\" & "bytes" & "\", vbDirectory) = "" Then
            
            MkDir ThisWorkbook.Path & "\" & "bytes" & "\"
            ck_dir = False
        End If
    Else
        ck_dir = True
        
    End If
    '시트 명으로 .bytes 파일명 지정, 안해도 되지만 프로그래머분이 이름을 다르게 쓰니 뭐...
    If str_SheetName = "string_ui" Then
        byteName = "StringUITable"
        ElseIf str_SheetName = "weapon_info" Or str_SheetName = "fxList" Then
            If str_SheetName = "weapon_info" Then byteName = "WeaponObj"
            If str_SheetName = "fxList" Then byteName = "Effect"
            byteName = byteName & "Table"
        Else
        byteName = UCase(Left(str_SheetName, 1))
        If InStr(1, str_SheetName, "_") Then
            ' _ 있는 시트명 처리
            byteName = byteName & Mid(str_SheetName, 2, InStr(1, str_SheetName, "_") - 2)
            
            byteName = byteName & UCase(Mid(str_SheetName, InStr(1, str_SheetName, "_") + 1, 1)) _
                & Mid(str_SheetName, InStr(1, str_SheetName, "_") + 2, Len(str_SheetName))
            Else
                '_ 없는 시트명 처리
                byteName = UCase(Left(str_SheetName, 1)) & Mid(str_SheetName, 2, Len(str_SheetName))
        End If
        

        byteName = byteName & "Table"
    End If
    str_Path = ThisWorkbook.Path & "\" & "bytes" & "\" & byteName & ".bytes"
    str_workPath = "D:\work\DataTables\" & byteName & ".bytes"
    '이전파일이 있다면 삭제
    If Dir(str_Path) <> vbNullString Then
        Kill str_Path
    End If
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '.bytes 생성
    
    Const adTypeBinary = 1
    Const adSaveCreateOverWrite = 2
    
    Set Body = CreateObject("ADODB.Stream")
    Body.Type = 1
    Body.Open

    'sheet 의 사이즈를 확인하고
    int_NFields = Application.CountA(Worksheets(str_SheetName).Range("1:1"))
    int_NData = Application.CountA(Worksheets(str_SheetName).Range("a:a"))
    
    'sheet 내용을 bytes 로 변환
'    'header 입력
'    For j = 1 To int_NFields
'
'        'sheet 의 내용 중 데이터에 들어가지 않는 것 필터링,  글꼴이 기울임이면 제외
'        If Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "기울임꼴" Or Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "굵은 기울임꼴" Then
'        Else
'            If str_Target = vbNullString Then
'                str_Target = Worksheets(str_SheetName).Cells(3, j).value
'            Else
'                str_Target = str_Target & "," & Worksheets(str_SheetName).Cells(3, j).value
'            End If
'        End If
'    Next j
'
'    Body.WriteText = str_Target & Chr(10)
'    str_Target = ""

    Dim Ndata_c As Long
    
    '키 개수 입력
    Ndata_c = 0
    For I = 4 To int_NData
        If Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "기울임꼴" Or Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "굵은 기울임꼴" Then
        
        Else
            Ndata_c = Ndata_c + 1
        End If
    Next I
    Body.Write LongToByteArray(Ndata_c)
    'body 입력
    
    For I = 4 To int_NData
        If Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "기울임꼴" Or Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "굵은 기울임꼴" Then
        '기본키 내용 중 기울임꼴인것 필터
        Else
            For j = 1 To int_NFields
                If Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "기울임꼴" Or Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "굵은 기울임꼴" Then
                'sheet 의 내용 중 데이터에 들어가지 않는 것 필터링
                
                Else

                    '필드 내용 확인후 쓰기
                    var_TempType = UCase(Worksheets(str_SheetName).Cells(1, j).value)
                    var_TempValue = Worksheets(str_SheetName).Cells(I, j).value
                    If var_TempType = "INT" Then
                    'int 오버플로우 체크
                        If var_TempValue < -2147483648# Or var_TempValue > 2147483647 Then
                            If var_TempValue <> "" Then MsgBox Worksheets(str_SheetName).Name & " " & Worksheets(str_SheetName).Cells(I, j).Address & " 셀의 값(" & var_TempValue & ")이 범위를 넘었습니다(" & var_TempType & ").", Title:=strTitle
                            'int 타입일 때 "" value 에 대한 예외처리
                            Else
                                'int 타입일 때 처리
                                If str_SheetName = "monster_group" And j = int_NFields Then
                                
                                var_TempLong = Worksheets(str_SheetName).Cells(I, j).value
                                Body.Write LongToByteArray(var_TempLong)
                                
                                var_TempPrebyte = StrConv(Chr(255), vbFromUnicode)
                                Body.Write var_TempPrebyte
                                Body.Write var_TempPrebyte
                                Body.Write var_TempPrebyte
                                Body.Write var_TempPrebyte
                                Else
                                var_TempLong = Worksheets(str_SheetName).Cells(I, j).value
                                Body.Write LongToByteArray(var_TempLong)
                                End If
                        End If


                    ElseIf var_TempType = "BYTE" Then
                    'byte 오버플로우 체크
                        If var_TempValue < -1 Or var_TempValue > 256 Then
                            'byte 타입일 때 "" value 에 대한 예외처리
                            If var_TempValue <> "" Then MsgBox Worksheets(str_SheetName).Name & " " & Worksheets(str_SheetName).Cells(I, j).Address & " 셀의 값(" & var_TempValue & ")이 범위를 넘었습니다(" & var_TempType & ").", Title:=strTitle
                            Else
                            'byte 타입일 때 처리
                            var_Tempbyte2 = Worksheets(str_SheetName).Cells(I, j).value
                            Body.Write ByteToByteArray(var_Tempbyte2)
                        End If
                            
                        
                    ElseIf var_TempType = "STRING" Then
                    'string 인경우
'                        var_TempString = Chr(Len(Worksheets(str_SheetName).Cells(I, j).value)) + Worksheets(str_SheetName).Cells(I, j).value
'                        var_Tempbyte = StrConv(var_TempString, vbFromUnicode)
                        
                        'utf8 변환
                        var_TempString = Worksheets(str_SheetName).Cells(I, j).value
                        var_Tempbyte = Utf8BytesFromString(var_TempString)

                        'var_TempPrebyte = StrConv(Chr(LenMbcs(Worksheets(str_SheetName).Cells(I, j).value)), vbFromUnicode)
                        var_TempPrebyte = StrConv(Chr(UBound(var_Tempbyte) - LBound(var_Tempbyte) + 1), vbFromUnicode)
                        Body.Write var_TempPrebyte
                        Body.Write var_Tempbyte
                    
                    ElseIf var_TempType = "FLOAT" Then
                    
                    'float 인경우
                        var_TempFloat = Worksheets(str_SheetName).Cells(I, j).value
                        var_Tempbyte = SingToByte(var_TempFloat)
                        Body.Write var_Tempbyte
                    
                    End If
                    
'                    '줄바꿈이 있거나, 콤마(,)가 있을 때 별도 처리
'                    If InStr(var_TempValue, Chr(10)) > 0 Or InStr(var_TempValue, ",") > 0 Then
'
'                        var_TempValue = """" & var_TempValue & """"
'
'                    End If
'
'                    If str_Target = vbNullString Then
'                        str_Target = var_TempValue
'                    Else
'                        str_Target = str_Target & "," & var_TempValue
'
'                        'str_Target = str_Target & "," & Worksheets(str_SheetName).Cells(3, j).Value
'
'                    End If
                            
                End If
            
            Next j
        
'            Body.WriteText = str_Target & Chr(10)
'            str_Target = ""
        End If
    Next I
    
    If ck_dir Then
        Body.savetofile str_workPath, adSaveCreateOverWrite
        Else
        Body.savetofile str_Path, adSaveCreateOverWrite
    End If
    Body.Close
    If ci <> 1 And ck_dir Then
        MsgBox str_workPath & Chr(10) & "데이터 익스포트 완료", Title:=strTitle
        
        Else
        MsgBox str_Path & Chr(10) & "데이터 익스포트 완료", Title:=strTitle
    End If
    
End Sub

Sub xls_export_Click(control As IRibbonControl) 'xls Export 버튼 클릭시 실행될 내용
    
    Call CreateXls
    MsgBox ThisWorkbook.Path & "\" & "xls" & "\" & Chr(10) & "xls 생성완료", Title:=strTitle
End Sub

Sub CreateXls()

    
    Dim sht As Worksheet
    Dim str_Path As String '저장 파일명
    Dim ob As Workbook '이전 워크북
    Dim wb As Workbook '생성워크북
    Dim str_SheetName As String
    
    Dim int_NFields As Integer
    Dim int_NData As Long
    Dim var_TempType, var_TempValue
    
    Dim I, j As Long '셀 반복
    
    Set ob = Application.ActiveWorkbook
    
    ' 저장 폴더 존재 여부 체크 후 없다면 생성
    If Dir(ob.Path & "\" & "xls" & "\", vbDirectory) = "" Then
        MkDir ob.Path & "\" & "xls" & "\"
    End If
    
    '워크북 명으로로 .xls 파일명 지정
    str_Path = ob.Path & "\" & "xls" & "\" & CreateObject("Scripting.FileSystemObject").GetBaseName(ob.Name) & "1.xlsx"
    
    '이전파일이 있다면 삭제
    If Dir(str_Path) <> vbNullString Then
        Kill str_Path
    End If
    
    
    '파일생성
    Set wb = Application.Workbooks.Add
    
    For Each sht In ob.Worksheets
        'If sht.Name <> "info" Then
        str_SheetName = sht.Name
        '중복키값 체크
        Call checkDulpicatePrimarykey(str_SheetName)
        Call checkDulpicateHeader(str_SheetName)
        Sheets.Add
        Sheets(1).Name = str_SheetName
        
        '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'sheet 복사
        int_NFields = Application.CountA(ob.Worksheets(str_SheetName).Range("1:1"))
        int_NData = Application.CountA(ob.Worksheets(str_SheetName).Range("a:a"))

        For I = 1 To int_NData
            If ob.Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "기울임꼴" Or ob.Worksheets(str_SheetName).Cells(I, 1).Font.FontStyle = "굵은 기울임꼴" Then
            '기본키 내용 중 기울임꼴인것 필터
            Else
                For j = 1 To int_NFields
                    If ob.Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "기울임꼴" Or ob.Worksheets(str_SheetName).Cells(3, j).Font.FontStyle = "굵은 기울임꼴" Then
                    'sheet 의 내용 중 데이터에 들어가지 않는 것 필터링
                    
                    Else
                        '필드 내용 확인후 쓰기
                        var_TempType = UCase(ob.Worksheets(str_SheetName).Cells(1, j).value)
                        var_TempValue = ob.Worksheets(str_SheetName).Cells(I, j).value
                        If var_TempType = "INT" Then
                        'int 오버플로우 체크
                            If I >= 4 Then
                                If var_TempValue < -2147483648# Or var_TempValue > 2147483647 Then
                                    If var_TempValue <> "" Then MsgBox ob.Worksheets(str_SheetName).Name & " " & ob.Worksheets(str_SheetName).Cells(I, j).Address & " 셀의 값(" & var_TempValue & ")이 범위를 넘었습니다(" & var_TempType & ").", Title:=strTitle
                                    'int 타입일 때 "" value 에 대한 예외처리
                                    Else
                                    'int 타입일 때 처리
                                    wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
                                End If
                                Else
                                wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
                            End If
                        ElseIf var_TempType = "STRING" Or var_TempType = "TXT" Then
                            'string 인경우
                            wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
    
                        ElseIf var_TempType = "FLOAT" Then
                        
                        'float 오버플로우 체크
                            If I >= 4 Then
                                If var_TempValue < -2147483648# Or var_TempValue > 2147483647 Then
                                    If var_TempValue <> "" Then MsgBox ob.Worksheets(str_SheetName).Name & " " & ob.Worksheets(str_SheetName).Cells(I, j).Address & " 셀의 값(" & var_TempValue & ")이 범위를 넘었습니다(" & var_TempType & ").", Title:=strTitle
                                    'int 타입일 때 "" value 에 대한 예외처리
                                    Else
                                    wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
                                End If
                                Else
                                'float 일때 처리
                                wb.Sheets(str_SheetName).Cells(I, j).value = ob.Worksheets(str_SheetName).Cells(I, j).value
                            End If
                        
                        End If
                    End If
                Next j
            End If
        Next I

    Next sht
    
    '알림 메시지 비활성화
    Application.DisplayAlerts = False
    '자동 생성된 시트 1 삭제
    wb.Sheets("sheet1").Delete
    
    '알림 메시지 활성화
    Application.DisplayAlerts = True
    
    '저장
    wb.SaveAs str_Path
    wb.Close
    MsgBox str_Path & Chr(10) & "데이터 익스포트 완료", Title:=strTitle
    
End Sub

음......괴랄해....

항상 느끼는 거지만 왜하고 있는거지...

C# (유니티?) 엔진 및 이펙트, 타격타이밍 등을 json 으로 저장하게 되면서

json 파일 정보를 엑셀에서 정리해야 되는 경우가 발생

+ json 파일이 줄바꿈되어 있지 않은 경우

+ 추가기능을 추가 하지 않고 파싱하여 가져와 보자

원본 json데이터 : "c:\eff.json"

{"target": [{"stateName": "ShortAttack","effectName": "vfx_hit_01_yellow","effectBulletName": "","boneName": "Bip001 Pelvis","startboneName": "","ftime": 0.25699999928474429,"fAngle": [],"isMelee": true,"fAngleX": [],"bulletCount": 0,"selectStartBoneidx": 0,"selectBoneidx": 3,"selectidx": 1,"objEffect": {"instanceID": 71280},"objBulletEffect": {"instanceID": 0}},{"stateName": "LongAttack","effectName": "fx_hit_laser_01_green","effectBulletName": "fx_laser_01_green","boneName": "Bip001 Pelvis","startboneName": "dummy_attack_long_01","ftime": 0.38999998569488528,"fAngle": [0.0],"isMelee": false,"fAngleX": [0.0],"bulletCount": 1,"selectStartBoneidx": 79,"selectBoneidx": 3,"selectidx": 2,"objEffect": {"instanceID": 67170},"objBulletEffect": {"instanceID": 58998}},{"stateName": "Smash","effectName": "vfx_hit_01_yellow","effectBulletName": "","boneName": "Bip001 Pelvis","startboneName": "","ftime": 0.5569999814033508,"fAngle": [],"isMelee": true,"fAngleX": [],"bulletCount": 0,"selectStartBoneidx": 0,"selectBoneidx": 3,"selectidx": 10,"objEffect": {"instanceID": 71280},"objBulletEffect": {"instanceID": 0}}]}

보는것과 같이 한줄로 주욱....되어 있는 경우가 대부분이다.

이걸 json 뷰어등으로 파싱하면..

{
  "target": [
    {
      "stateName": "ShortAttack",
      "effectName": "vfx_hit_01_yellow",
      "effectBulletName": "",
      "boneName": "Bip001 Pelvis",
      "startboneName": "",
      "ftime": 0.25699999928474429,
      "fAngle": [
        
      ],
      "isMelee": true,
      "fAngleX": [
        
      ],
      "bulletCount": 0,
      "selectStartBoneidx": 0,
      "selectBoneidx": 3,
      "selectidx": 1,
      "objEffect": {
        "instanceID": 71280
      },
      "objBulletEffect": {
        "instanceID": 0
      }
    },
    {
      "stateName": "LongAttack",
      "effectName": "fx_hit_laser_01_green",
      "effectBulletName": "fx_laser_01_green",
      "boneName": "Bip001 Pelvis",
      "startboneName": "dummy_attack_long_01",
      "ftime": 0.38999998569488528,
      "fAngle": [
        0.0
      ],
      "isMelee": false,
      "fAngleX": [
        0.0
      ],
      "bulletCount": 1,
      "selectStartBoneidx": 79,
      "selectBoneidx": 3,
      "selectidx": 2,
      "objEffect": {
        "instanceID": 67170
      },
      "objBulletEffect": {
        "instanceID": 58998
      }
    },
    {
      "stateName": "Smash",
      "effectName": "vfx_hit_01_yellow",
      "effectBulletName": "",
      "boneName": "Bip001 Pelvis",
      "startboneName": "",
      "ftime": 0.5569999814033508,
      "fAngle": [
        
      ],
      "isMelee": true,
      "fAngleX": [
        
      ],
      "bulletCount": 0,
      "selectStartBoneidx": 0,
      "selectBoneidx": 3,
      "selectidx": 10,
      "objEffect": {
        "instanceID": 71280
      },
      "objBulletEffect": {
        "instanceID": 0
      }
    }
  ]
}

이런 모양이 된다.

표로 보자면

여기서 내가 필요한것은

각 "stateName" 별 이벤트 발생시간 "ftime" 값이다.

Private p&, token, dic

Sub jsonDataRead()
	Set Arry = CreateObject("Scripting.Dictionary")
    Dim bb As Integer
	filename = "c:\eff.json"
	Open filename For Input As #1
        Do Until EOF(1)
			Line Input #1, textline
			Total = Total & vbNewLine & textline
		Loop
	Close #1
    If InStr(1, Total, vbCrLf) >= 1 Then 	'줄바꿈 되어 있는 데이터를 한줄로
    	Total = Replace(Total, vbCrLf, vbLf)
    End If
    Set Arry = ParseJSON(Total)
    For Each aa In Arry.keys '키기준으로 돌리자
    	If InStr(1, aa, "stateName") Then
          Fileline = Application.CountA(range("a:a")) 'a열 숫자 카운트 해서 다음에 넣자
          ActiveWorkbook.Activeworksheets.Cells(Fileline + 1, 1).Value = Arry.Items()(bb) 'aa
    	ElseIf InStr(1, aa, "ftime") Then
    		ActiveWorkbook.Activeworksheets.Cells(Fileline + 1, 2).Value = Arry.Items()(bb) 'aa
    	End If
    	bb = bb + 1
    Next
End Sub
'---------------------------------------------------------------------------
' VBA JSON Parser 도구 참조 추가 하지 않는  파서 Dictionary 형식으로 반환
'---------------------------------------------------------------------------

Function ParseJSON(json$, Optional key$ = "obj") As Object
    p = 1
    token = Tokenize(json)
    Set dic = CreateObject("Scripting.Dictionary")
    If token(p) = "{" Then ParseObj key Else ParseArr key
    Set ParseJSON = dic
End Function

Function ParseObj(key$)  '키 분해
    Do: p = p + 1
        Select Case token(p)
            Case "]"
            Case "[":  ParseArr key
            Case "{":  ParseObj key
            Case "}":  key = ReducePath(key): Exit Do
            Case ":":  key = key & "." & token(p - 1)
            Case ",":  key = ReducePath(key)
            Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
        End Select
    Loop
End Function

Function ParseArr(key$) '키 배열
    Dim e&
    Do: p = p + 1
        Select Case token(p)
            Case "}"
            Case "{":  ParseObj key & ArrayID(e)
            Case "[":  ParseArr key
            Case "]":  Exit Do
            Case ":":  key = key & ArrayID(e)
            Case ",":  e = e + 1
            Case Else: dic.Add key & ArrayID(e), token(p)
        End Select
    Loop
End Function

'-------------------------------------------------------------------
' Support Functions
'-------------------------------------------------------------------
Function Tokenize(s$) '값 토큰화
    Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
    Tokenize = RExtract(s, Pattern, True)
End Function

Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True) '값 추출
  Dim c&, m, n, v
  With CreateObject("vbscript.regexp")
    .Global = bGlobal
    .MultiLine = False
    .IgnoreCase = True
    .Pattern = Pattern
    If .test(s) Then
      Set m = .Execute(s)
      ReDim v(1 To m.Count)
      For Each n In m
        c = c + 1
        v(c) = n.Value
        If bGroup1Bias Then If Len(n.submatches(0)) Or n.Value = """""" Then v(c) = n.submatches(0)
      Next
    End If
  End With
  RExtract = v
End Function

Function ArrayID$(e) '값 배열
    ArrayID = "(" & e & ")"
End Function

Function ReducePath$(key$) '값패스 정리
    If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1)
End Function

변수 Arry에  Dictionary로 저장후 Arry.keys 로 for을 진행

원하는 항목 검사 InStr(1, aa, "빼내고자 하는 항목명") 해서

액티브 시트에 찍기

음...나중에도 쓸만하겠지?

와....xml 을 했더니 이제는 텍스트가 날 괴롭히네...

일반 적인 형식으로 읽으면 문자가 다 깨져서 objStream 으로 읽어야 한다..

별거 아닌데 은근 꽤 찾아야 나오더라는..;;

항상 엑셀로 데이터 관리하다보니 실제 xml 에 값이 없더라는

어이없는 경우가 발생

그럼? 펑션으로 해서 있는지를 체크하면되겠넹? ㅋㅋ

셀에 2라는 값이 있을때 text 의 값을 얻어와보자

ALT+F11 키눌러서 vba 창에서 도구 -> 참조 에서 Microsoft XML, v3.0 을 활성화 먼저 한다.

(안그러면 xml 안읽히더라고...6.0도 있던데 되는지는 안해봄)

Function xmlfind(key) '함수처럼 사용하기 위해 이름 주고, 셀값 저장)

    Dim XmlDoc As DOMDocument: Dim blnXml As Boolean 'xml 문서형식 지정, 체크값

    Dim strFileName As String: strFileName = "AAA.xml" ' 파일명

    Dim strPath As String: strPath = "c:\"& strFileName 'strPath에 폴더위치와 파일명

    Dim strMsg As String: strMsg = strPath & "파일을 불러오다가 에러가 발생했습니다."

    Set XmlDoc = CreateObject("Microsoft.XMLDom") '오브젝트로 지정

    blnXml = XmlDoc.Load(strPath) '파일있는지 확인

    Dim i As Integer, j As Integer '반복을 위한 변수 설정

    If blnXml = True Then '파일읽었다면?

        With XmlDoc.ChildNodes(1) '문서 끝가지 반복

        For i = 0 To .ChildNodes.Length - 1 '첫번째 노드 key 의 끝까지 반복

            If key = .ChildNodes(i).ChildNodes(0).Text Then 'key 가 셀값과 같은가?

                xmlfind = .ChildNodes(i).ChildNodes(1).Text '해당 노드 값을 반환

                Exit For

            End If

        Next i

        End With

        Set XmlDoc = Nothing 'xml 껏졍

    Else

xmlfind =  strMsg & vbCrLf & Err.Number & " : " _

                   & Err.Description   '오류시 오류사항 리턴

    End If

End Function

언제나 느끼지만 나 이거 왜하고 있는거지....