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 If
notNeededColumn:
            Next

opCodeIsNull:       
        Next

notValidWorksheet:
    Next

    ' 删除最后一个逗号, 在循环中处理太麻烦, 效率也不高
    recordJsonStr = Left(recordJsonStr, Len(recordJsonStr) - 1)
    recordJsonStr = recordJsonStr & "}"
    write2file (recordJsonStr)

End Sub

Public Sub printMsg(ByVal msg)
    Debug.Print msg
End Sub

Public 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 If

End Function

Sub 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 = Nothing
End 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 = str
End Function

欢迎拍砖.