将锯齿状数组存储在VBA中的已定义名称中

问题描述

我需要以定义的名称存储一个锯齿状的数组，以便可以保存它，并在重新打开工作簿时引用其内容。下面的代码以正确的尺寸漂亮地创建了锯齿状的数组，但是Names.Add方法会产生“运行时错误'1004'：应用程序定义的错误或对象定义的错误”。
调试相关行时，将鼠标悬停在单词“名称”上会提示“对象变量或未设置块变量”。我尝试使用'Set'语句将Fee3数组转换为对象以及其他我能想到的方法来更改变量名称。请帮忙。

Sub GetFee3Codes()
Dim r1 As Integer,r2 As Integer,r3 As Integer,r4 As Integer,r5 As Integer,c5 As Integer
Dim Fee3,UserType,ClientType,StartDate,PayerType,RateOrAmt
ReDim Fee3(1),UserType(1),ClientType(3),StartDate(3),PayerType(14),RateOrAmt(14,3)
    For r1 = 1 To 1
        Fee3(r1) = UserType
        For r2 = 1 To 1
            Fee3(r1)(r2) = ClientType
            For r3 = 1 To 3
                Fee3(r1)(r2)(r3) = StartDate
                For r4 = 1 To 3
                    Fee3(r1)(r2)(r3)(r4) = PayerType
                    For c5 = 1 To 3
                        For r5 = 1 To 14
                            Fee3(r1)(r2)(r3)(r4)(r5) = RateOrAmt
                        Next r5
                    Next c5
                Next r4
            Next r3
        Next r2
    Next r1
    Names.Add Name:="Fee3",RefersTo:=Fee3,Visible:=True
    ThisWorkbook.Save
End Sub

解决方法

这是我在评论中提到的方法。由于可以将文本存储在命名范围内，因此可以将数组序列化为JSON，然后在需要时反序列化。虽然，我认为仅运行Workbooks_Open事件中具有的方法会更容易，如Ron Rosenfeld所指出的那样。

您需要添加以下代码中引用的VBA JSON项目。

Option Explicit

'You'll need the VBA JSON Project installed https://github.com/VBA-tools/VBA-JSON
'Also,will need a reference to Microsoft Scripting Runtime added
Sub AddJaggedArrayAsName()
    'Create an array
    Dim arrayExample As Variant
    ReDim arrayExample(1 To 2,1 To 2)
    
    arrayExample(1,1) = "A"
    arrayExample(1,2) = "B"
    arrayExample(2,1) = "C"
    arrayExample(2,2) = "D"
    
    'Convert the array to JSON and add to name range
    Dim Json As String
    Json = JsonConverter.ConvertToJson(arrayExample,Whitespace:=2)
    ThisWorkbook.Names.Add Name:="Something",RefersTo:=Json,Visible:=True
        
    'Parse the JSON back to an object and iterate
    Dim JsonObject As Object
    Dim RefersToString As String: RefersToString = ThisWorkbook.Names("Something").RefersTo
    Dim JsonStringFromNamedRange As String
    
    'Remove starting equal sign and extra quotes
    JsonStringFromNamedRange = Replace(Mid$(RefersToString,3,Len(RefersToString) - 3),"""""","""")
    Debug.Print JsonStringFromNamedRange 'JSON here
    
    Set JsonObject = JsonConverter.ParseJson(JsonStringFromNamedRange)
    Dim key As Variant
    Dim item As Variant
    
    'Iterate and show values
    For Each key In JsonObject
        For Each item In key
            Debug.Print item
        Next
    Next
    
End Sub