Function CreateArray(ByRef arrObj As Object, _
                ByVal arrName As String, _
                Optional ByVal Nrazmer As String = vbNullString) As Boolean
Dim arrn, i As Long, regs As Object, Response
Set regs = NewDict
'-------------------------------------------------------------------------------
'проверка существования массива
If arrObj.Exists(arrName) Then
    Response = MsgBox("Массив '" & arrName & "' уже существует. Заменить?", vbYesNo, "Вопрос")
    If Response = vbYes Then
        arrObj.Remove arrName
    Else
        MsgBox "Массив '" & arrName & "' не создан.": Exit Function
    End If
End If
'-------------------------------------------------------------------------------
'создание массива
arrObj.Add arrName, NewDict
arrObj(arrName).Add "Name", arrName
arrObj(arrName).Add "Razmer", NewDict
arrObj(arrName).Add "Values", NewDict
arrObj(arrName)("Razmer").Add "flag", True
arrObj(arrName)("Razmer").Add "N", Nothing
Nrazmer = Replace(Nrazmer, " ", vbNullString)
arrObj(arrName)("Razmer")("flag") = (Nrazmer <> vbNullString) 'False - нет ограничений по n-размерности массива
If arrObj(arrName)("Razmer")("flag") Then
    Set arrObj(arrName)("Razmer")("N") = NewDict
    arrn = Split(Nrazmer, ",")
    For i =  0  To UBound(arrn,  1 )
        CreateArray = False
        arrObj(arrName)("Razmer")("N").Add i, NewDict
        If preg_match(NewReg, "^(\d+)$", CStr(arrn(i)), regs) Then ' размерность типа - количество элеметнов X (от 0 до X-1)
            arrObj(arrName)("Razmer")("N")(i).Add "flag", True 'True - есть ограничения по количеству элементов массива
            arrObj(arrName)("Razmer")("N")(i).Add "from", CLng( 0 )
            arrObj(arrName)("Razmer")("N")(i).Add "to", CLng(regs( 1 )) -  1 
            CreateArray = True
        End If
        If preg_match(NewReg, "^(\d+)to(\d+)$", CStr(arrn(i)), regs) Then ' размерность типа - от Х до Y
            arrObj(arrName)("Razmer")("N")(i).Add "flag", True 'True - есть ограничения по количеству элементов массива
            If CLng(regs( 0 )) <= CLng(regs( 1 )) Then
                arrObj(arrName)("Razmer")("N")(i).Add "from", CLng(regs( 1 ))
                arrObj(arrName)("Razmer")("N")(i).Add "to", CLng(regs( 2 ))
                CreateArray = True
            Else
                CreateArray = False
            End If
        End If
        If CStr(arrn(i)) = vbNullString Then ' массив безразмерен
            arrObj(arrName)("Razmer")("N")(i).Add "flag", False  'False - нет ограничений по количеству элементов массива
            CreateArray = True
        End If
        If Not CreateArray Then
            MsgBox "Неправильно задана размерность '" & CStr(arrn(i)) & "', массив '" & arrName & "' не создан."
            arrObj.Remove arrName
            Exit Function
        End If
    Next
End If
End Function

Property Let ValueArray(ByRef arrObj As Object, _
                ByVal arrName As String, _
                ByVal Nrazmer As String, _
                ByVal arrValue)
If Not arrObj.Exists(arrName) Then
    MsgBox "Массив '" & arrName & "' не существует."
    Exit Property
End If
Dim flag As Boolean
Nrazmer = Replace(Nrazmer, " ", vbNullString)
If arrObj(arrName)("Razmer")("flag") Then
    Dim arrn, N As Long, i As Long
    arrn = Split(Nrazmer, ",")
    N = CLng(UBound(arrn,  1 ) +  1 ) 'размерность, указанная при вводе
    If CLng(arrObj(arrName)("Razmer")("N").Count) = N Then ' сверка размерностей
        For i =  0  To UBound(arrn,  1 )
            If arrObj(arrName)("Razmer")("N")(i)("flag") Then
                N = CLng(arrn(i))
                flag = (arrObj(arrName)("Razmer")("N")(i)("from") <= N And N <= arrObj(arrName)("Razmer")("N")(i)("to"))
                If Not flag Then MsgBox MsgBox "Массив '" & arrName & "': при записи неправильно указан индекс массива."
            Else
                flag = True
            End If
        Next
    Else
        MsgBox "Массив '" & arrName & "': при записи неправильно указана размерность массива"
        flag = False
    End If
Else
    flag = True
End If
'-----------------------------------------------------------
If flag Then
    If arrObj(arrName)("Values").Exists(Nrazmer) Then
        arrObj(arrName)("Values")(Nrazmer) = arrValue
    Else
        arrObj(arrName)("Values").Add Nrazmer, arrValue
    End If
End If
End Property

'-----------------------------------------------------------
If flag Then
    If arrObj(arrName)("Values").Exists(Nrazmer) Then
        ValueArray = arrObj(arrName)("Values")(Nrazmer)
    Else
        MsgBox "Значение отсутствует"
        ValueArray = Empty
    End If
End If

Function NewDict() As Object
Set NewDict = CreateObject("Scripting.Dictionary")
End Function

Function NewReg() As Object
Set NewReg = CreateObject("VBScript.RegExp")
NewReg.Global = True
NewReg.IgnoreCase = True
NewReg.MultiLine = True
End Function

Public Function preg_match(ByRef reg As Object, ByVal match As String, ByVal str As String, Optional ByRef regs As Object = Nothing) As Boolean
Dim i As Integer
reg.Pattern = match
If reg.Test(str) Then
    preg_match = True
    If Not regs Is Nothing Then
        regs.RemoveAll
        With reg.Execute(str).Item( 0 ).Submatches
            For i =  0  To .Count -  1 
                regs.Add i +  1 , Trim(.Item(i))
            Next
        End With
    End If
Else
    preg_match = False
End If
End Function

Set arrGlobal = NewDict

CreateArray arrGlobal, "arrTest0"
CreateArray arrGlobal, "arrTest1", "10"
CreateArray arrGlobal, "arrTest2", "10, 20"
CreateArray arrGlobal, "arrTest3", "0 To 10"
CreateArray arrGlobal, "arrTest4", "10, 1 To 10"
CreateArray arrGlobal, "arrTest5", "1 To 10, 10 To 100"
CreateArray arrGlobal, "arrTest6", "5, 1 To 10, 10 To 100, 1000"

ValueArray(arrGlobal, "arrTest0", "0") =  1 
ValueArray(arrGlobal, "arrTest0", "0, 1") =  3 
ValueArray(arrGlobal, "arrTest1", "1") =  2 
ValueArray(arrGlobal, "arrTest2", "1, 2") =  3 
ValueArray(arrGlobal, "arrTest3", "3") =  4 
ValueArray(arrGlobal, "arrTest4", "5, 6") =  4 
ValueArray(arrGlobal, "arrTest6", "3, 5, 20, 300") =  4 

MsgBox ValueArray(arrGlobal, "arrTest6", "3, 5, 20, 300")