SAP资产负债表实现方案探索 - 基于 VBA 自定义函数方法

本篇接着SAP资产负债表实现方案探索 - 基于 Excel-DNA 自定义函数方法 这篇博文，继续介绍通过 VBA 编写自定义函数来实现资产负债表的方法。在上一篇文章中，整体解决方案的思路可以分为两个步骤：（1）SAP 提供 Restful Service，允许外部获取 json 格式的科目余额表；(2) Excel 通过自定义函数从 Restful Service 中获取所需要的数据。

因为上一篇已经介绍了在 SAP 中如何提供 SAP Restful 服务，这里就不重复了，直接从在 Excel 中通过 VBA 自定义函数开始。

将 VBA 自定义函数放到加载宏中

为了实现自定义函数的复用，可以将自定义的函数放到加载宏 (add-in) 中，方法是将 Excel 文件另存为 Excel 加载宏，Excel 加载宏的扩展名为 xlam。

在每台 PC 上都有默认的 Excel 加载宏位置，放在默认位置的加载宏能在「Excel加载宏」对话框中显示，放在其他位置的加载宏能通过浏览的方式找到并加载。默认位置：C:\Users\UserName\AppData\Roaming\Microsoft\AddIns

Excel 通过 VBA 使用 Restful Service 需要解决两个问题：1）发送和接收 Http 请求，可以使用 Microsoft WinHTTP Service 5.1 这个库来实现，之前的博文有讲解过。本例因为只涉及到 Get 请求，可以使用 Excel 的 WebService 函数；2）第二个问题是对 json 数据的解析，我使用了 github 上一个开源的代码：VBA-tools/VBA-JSON: JSON conversion and parsing for VBA。

有了上面的准备工作，编写 BsItemAmount 函数用于从 SAP 获取报表项余额：

Public Const BaseUrl As String = "http://sapecc6:8000/sap/zrfc/"

Public Enum amtTypeEnum
    YEAR_BEGIN = 1
    PERIOD_BEGIN = 2
    PERIOD_DEBIT = 3
    PERIOD_CREDIT = 4
    PERIOD_NET = 5
    CLOSING = 6
End Enum


Public Function BsItemAmount(companyCode As String, year As String, period As String, fsItem As String, amountType As amtTypeEnum) As Double
    Dim jsonData As String
    Dim url As String
    Dim parsedDict As Dictionary
    Dim rv As Double ' 返回值
    
    url = BaseUrl & "Z_BS_BALANCES?COMPANYCODE=" & companyCode & "&FISCALYEAR=" & year & "&FISCALPERIOD=" & period
    jsonData = Application.WorksheetFunction.WebService(url)
    Set parsedDict = JsonConverter.parseJson(jsonData)
    
    Dim val As Dictionary
    For Each val In parsedDict("FS_BALANCES")
        If val("FSITEM") = fsItem Then
            If amountType = amtTypeEnum.YEAR_BEGIN Then
                rv = val("YR_OPENBAL")
            ElseIf amountType = amtTypeEnum.PERIOD_BEGIN Then
                rv = val("OPEN_BALANCE")
            ElseIf amountType = amtTypeEnum.PERIOD_DEBIT Then
                rv = val("DEBIT_PER")
            ElseIf amountType = amtTypeEnum.PERIOD_CREDIT Then
                rv = val("CREDIT_PER")
            ElseIf amountType = amtTypeEnum.PERIOD_NET Then
                rv = val("PER_AMT")
            ElseIf amountType = amtTypeEnum.CLOSING Then
                rv = val("BALANCE")
            End If
            
            Exit For
        End If
    Next
    
    BsItemAmount = rv
End Function

我们先对代码的功能做一个大致说明，后面再展开讲解关键的细节。上面这段代码做了两件事，先用 Excel 内置的 WebService 函数获取 SAP Restful service 的值，返回值为 json 字符串，然后通过 JsonConverter 对 json 字符串进行解析。 Json 字符串中的对象 (也就是花括号包括的部分）解析为 Dictionary，将 Json 字符串中的数组 (也就是方括号包括的部分) 解析为 Collection。

使用加载宏中的自定义函数

打开一个新的 Excel 工作簿，切换到「开发工具」页签，点击「Excel加载项」

从弹出对话框中选择合适的加载宏，如果加载宏不在默认位置，点击浏览按钮选择目标文件。

然后就可以愉快地使用自定义函数了（类别为：用户定义）

Restful Service 加载到 Excel 的方法

在写上面函数的时候，发现 VBA 在调试 Dictionary 或者 Collection 的时候挺不直观的，为了方便自己查看数据，就想着将数据导出到 Excel 工作表中。数据导出大体可以用两种方法。

方法一：基于解析的 Collection 和 Dictionary 写入工作表，代码如下：

Public Sub DataToSheet(data As Collection, shtName As String)
    ' data的类型为JsonConverter的parseJson()方法的返回值，而不是普通的Collection
    
    Dim sht As Worksheet
    Set sht = ActiveWorkbook.Sheets(shtName)
    
    Dim topLeftCell As Range
    Set topLeftCell = sht.Range("A1")
    
    ' 在第一行打印表头
    Dim firstRow As New Dictionary
    Dim k As Variant
    Dim col As Integer
    Set firstRow = data.Item(1)
    col = 0 ' col index
    For Each k In firstRow.Keys
        topLeftCell.Offset(0, col) = CStr(k)
        col = col + 1
    Next
    
    ' 打印line item的值
    Dim val As Dictionary
    Dim row As Integer ' row index
    row = 0
    col = 0
    For Each val In data
        For Each k In val.Keys
            topLeftCell.Offset(row + 1, col) = val(k)
            col = col + 1
        Next
        col = 0
        row = row + 1
    Next
End Sub

测试代码：

Public Sub WriteToSheetTest(ByVal shtName As String)
    Dim jsonData As String
    Dim url As String
    Dim parsedDict As Dictionary
    
    url = BaseUrl & "Z_BS_BALANCES?COMPANYCODE=Z900&FISCALYEAR=2020&FISCALPERIOD=10"
    jsonData = Application.WorksheetFunction.WebService(url)
    Set parsedDict = JsonConverter.parseJson(jsonData)
    
    Dim data As New Collection
    Set data = parsedDict("FS_BALANCES")
    Call DataToSheet(data, shtName)
End Sub

方法二：将数据加载到 ADODB.RecordSet，利用 VBA 中 Excel Range 提供的 CopyFromRecordSet() 将数据导入 Excel 工作表。代码如下：

Public Function DataToRecordSet(data As Collection) As ADODB.Recordset
    Dim rst As New ADODB.Recordset
    
    Dim firstRow As New Dictionary
    Dim k As Variant
    Set firstRow = data.Item(1)
'    For Each k In firstRow.Keys
'        rst.Fields.Append k, adVarChar, 50, adFldMayBeNull
'    Next
    rst.Fields.Append firstRow.Keys(0), adVarChar, 50, adFldKeyColumn
    rst.Fields.Append firstRow.Keys(1), adDouble
    rst.Fields.Append firstRow.Keys(2), adDouble
    rst.Fields.Append firstRow.Keys(3), adDouble
    rst.Fields.Append firstRow.Keys(4), adDouble
    rst.Fields.Append firstRow.Keys(5), adDouble
    rst.Fields.Append firstRow.Keys(6), adDouble
    
    rst.CursorType = adOpenKeyset
    rst.CursorLocation = adUseClient
    rst.LockType = adLockPessimistic
    
    Dim val As Dictionary
    Dim col As Integer
    
    ' 加载数据
    rst.Open
    For Each val In data
        rst.AddNew
        col = 0
        For Each k In val.Keys
            rst.Fields(col) = val(k)
            col = col + 1
        Next
        rst.Update
    Next
    
    Set DataToRecordSet = rst
End Function

注释掉的代码提供了更通用的功能，但因为数据类型无法确定，都默认为 varchar，效果不好，就改为根据数据本身的类型来确定 RecordSet 字段的数据类型。

测试代码如下。 先编写一个函数来获取值：

Public Function GetRecordSet() As ADODB.Recordset
    Dim jsonData As String
    Dim url As String
    Dim parsedDict As Dictionary
    
    url = BaseUrl & "Z_BS_BALANCES?COMPANYCODE=Z900&FISCALYEAR=2020&FISCALPERIOD=10"
    jsonData = Application.WorksheetFunction.WebService(url)
    Set parsedDict = JsonConverter.parseJson(jsonData)
    
    Dim data As New Collection
    Set data = parsedDict("FS_BALANCES")
    
    Dim rst As New ADODB.Recordset
    Set rst = DataToRecordSet(data)
    
    Set GetRecordSet = rst
End Function

然后再将数据导出到工作表：

Public Sub ExportDataTest()
    Dim rst As New ADODB.Recordset
    Set rst = StoneSAPFunctions.printModule.GetRecordSet
    
    ' print header
    Dim col As Integer
    For col = 0 To rst.Fields.Count - 1
        Sheet1.Range("A1").Offset(0, col) = rst.Fields(col).Name
    Next
    
    ' print line items
    rst.MoveFirst
    Sheet1.Range("A2").CopyFromRecordset rst
End Sub

在 CopyFromRecordset() 方法前，需要调用 Recordset 的 MoveFirst() 方法，否则游标处在最后一行，只打印出最后一行。