Excel轉JSON

由於項目需要, 需要將特定的Excel檔案提取為JSON, 試了Office2013版本後的外掛程式Excel to JSON後, 發現只能挨個工作錶轉換, 而且轉換效果也不理想;
第二種方法, 將工作錶轉換成CSV, 再由Java解析, 這樣還是得挨個工作錶轉換, 嫌麻煩.

但是之前看過一點VBA, 所以才鼓足勇氣寫vb指令碼解決問題.

下面的代碼由於商業原因, 不能有太多注釋, Excel檔案也無法提供, 僅以此紀念我的執著.

Sub opRecors2Json()    Dim recordJsonStr As String    recordJsonStr = "{"    Dim totalWorksheets As Long                  ' how many worksheets    Dim i As Long                                ' loop variable    Dim j As Long                                ' loop variable    Dim k As Long                                ' loop variable    Dim x As Long    ' const declarations    Const COLUMN_INDEX_OP_CODE As Long = 3           Const COLUMN_INDEX_OP_FIELD As Long = 5          Const COLUMN_INDEX_OP_FIELD_CN As Long = 7       Const ROW_INDEX_START As Long = 3                Dim currWorksheet As Worksheet                  ' current worksheet    Dim currRow As Range                            ' current row    Dim currCell As Range                           ' current cell    Dim currCellValue As String                     ' current cell's value    Dim currCellMergeCount As Long                  ' current cell's merge's count    Dim currOpCode As String                        ' operation code    Dim currOpField As String                       ' api field    Dim currOpFieldCN As String                     ' api field's Chinese    Dim worksheetName As String                     ' curr worksheet name    Dim totalRows As Long                           ' how many rows in current worksheet    Dim totalColumns As Long                        ' how many columns in current worksheet    totalWorksheets = Worksheets.Count    Const OFFSET_FIELD_OP_CODE As Integer = COLUMN_INDEX_OP_FIELD - COLUMN_INDEX_OP_CODE    Const OFFSET_FIELD_CN_OP_CODE As Integer = COLUMN_INDEX_OP_FIELD_CN - COLUMN_INDEX_OP_CODE    For i = 1 To totalWorksheets        Set currWorksheet = Worksheets(i)        worksheetName = currWorksheet.Name        ' filter worksheet        If (StrComp(trim2(worksheetName), "notNeededWorkSheet", vbTextCompare) = 0) Then            GoTo notValidWorksheet             End If        totalRows = currWorksheet.Range("A65535").End(xlUp).Row        totalColumns = currWorksheet.Range("IV4").End(xlToLeft).Column        ' printMsg (worksheetName & ": " & totalRows & ": " & totalColumns)        ' printMsg ("------------------------------------")        For j = ROW_INDEX_START To totalRows                ' ignore first tow rows            For k = COLUMN_INDEX_OP_CODE To totalColumns    ' ignore first one columns (sequence and api)                If k <> COLUMN_INDEX_OP_CODE _                    And k <> COLUMN_INDEX_OP_FIELD _                    And k <> COLUMN_INDEX_OP_FIELD_CN Then                    GoTo notNeededColumn                    ' continue                End If                Set currCell = currWorksheet.Cells(j, k)    ' 目前的儲存格                currCellValue = currCell.Value              ' 目前的儲存格的值                currCellMergeCount = currCell.MergeArea.Rows.Count ' 目前的儲存格合并個數                If k = COLUMN_INDEX_OP_CODE Then                    currCellValue = trim2(currCellValue)                    currOpCode = quoteStr(currCellValue)                    If VBA.IsNumeric(currCellValue) Then                        ' currOpCode = CLng(currCellValue)                        ' printMsg (worksheetName & "-" & j & "th row is number: " & currOpCode & ", merged: " & currCellMergeCount)                        ' 單行的情況                        If currCellMergeCount = 1 Then                            currOpField = quoteStr(trim2(currOpField))                            currOpFieldCN = quoteStr(trim2(currOpFieldCN))                            recordJsonStr = recordJsonStr & currOpCode & ":{" & currOpField & ":" & currOpFieldCN & "},"                        Else                            recordJsonStr = recordJsonStr & currOpCode & ":{"                            ' 直接從當前行往下讀, 一共currCellMergeCount行                            For x = 1 To currCellMergeCount                                currOpField = currWorksheet.Cells(j + x - 1, COLUMN_INDEX_OP_FIELD).Value                                currOpFieldCN = currWorksheet.Cells(j + x - 1, COLUMN_INDEX_OP_FIELD_CN).Value                                currOpField = quoteStr(trim2(currOpField))                                currOpFieldCN = quoteStr(trim2(currOpFieldCN))                                recordJsonStr = recordJsonStr & currOpField & ":" & currOpFieldCN                                If x <> currCellMergeCount Then                                    recordJsonStr = recordJsonStr & ","                                End If                            Next                            recordJsonStr = recordJsonStr & "},"                        End If                    End If                End IfnotNeededColumn:            NextopCodeIsNull:               NextnotValidWorksheet:    Next    ' 刪除最後一個逗號, 在迴圈中處理太麻煩, 效率也不高    recordJsonStr = Left(recordJsonStr, Len(recordJsonStr) - 1)    recordJsonStr = recordJsonStr & "}"    write2file (recordJsonStr)End SubPublic Sub printMsg(ByVal msg)    Debug.Print msgEnd SubPublic Function isNullStr(ByRef str As String) As Boolean    Dim lenOfStr As Long    lenOfStr = Len(str)    If lenOfStr = 0 Then        isNullStr = True    Else        isNullStr = False    End IfEnd FunctionSub write2file(ByVal content As String)     Dim objStream As Object     Set objStream = CreateObject("ADODB.Stream")     Dim filename As String     filename = Application.GetSaveAsFilename("recordResult.json", "(*.json),*.json")     If filename <> "False" Then        With objStream            .Type = 2            .Charset = "UTF-8"            .Open            .WriteText content            .SaveToFile filename, 2        End With    Else        MsgBox "儲存失敗", vbOKOnly, "儲存為json"    End If     Set objStream = NothingEnd Sub' 使用雙引號包裹字串Public Function quoteStr(ByRef str As String) As String    quoteStr = Chr(34) & str & Chr(34)End Function' 有的欄位說明中有換行, 英文雙引號, 導致出錯' 故寫此函數Function trim2(ByVal str As String) As String    str = Trim(str)    str = Replace(str, Chr(34), "")    str = Replace(str, Chr(13), "")    str = Replace(str, Chr(10), "")    trim2 = strEnd Function

歡迎拍磚.