Sub test_FnDicInAr()

Dim lngClnStart As Long

Dim lngClnEnd As Long

Dim lngRowStart As Long

Dim lngRowEnd As Long

Dim aTemp As Variant

lngClnStart = 1

lngRowStart = 2

 

    With ThisWorkbook

        With .Sheets("ListZonePSFV")

            lngClnEnd = .Cells(1, 256).End(xlToLeft).Column

            lngRowEnd = .Columns(1).Rows(65536).End(xlUp).Row

            aTemp = Range(.Cells(lngRowStart, lngClnStart), .Cells(lngRowEnd, lngClnEnd)).Value

        End With

    End With

   

    Set dicZone_DEPT = FnDicInAr(aTemp, 1, 4)

    Set dicZone_UET = FnDicInAr(aTemp, 1, 6)

    Set dicZone_Time_A = FnDicInAr(aTemp, 1, 10)

    Set dicZone_Time_C = FnDicInAr(aTemp, 1, 11)

End Sub

 

'====================================================================================================

' ##### словарь из двумерного(Одномерного) массива

'

'----------------------------------------------------------------------------------------------------

Function FnDicInAr(ByVal aTemp As Variant, _

                    ByVal lngClnKey As Long, _

                    ByVal lngClnItem As Long) As Object

                   

Dim FnDicPi As Object

Dim strPi As String

Dim i As Long

Dim iNbCln1 As Integer 'первый столбец

Dim iNbCln2 As Integer 'второй столбец

On Error Resume Next

 

iNbCln1 = LBound(aTemp)

'iNbCln2 = UBound(aTemp, 2)

iNbCln2 = RazmerArray(aTemp)

'If iNbCln1 <> iNbCln2 Then Stop

    Set FnDicPi = CreateObject("scripting.dictionary"): FnDicPi.comparemode = 1

    For i = LBound(aTemp) To UBound(aTemp)

       

        If iNbCln1 = iNbCln2 Then  'если два столбца

            strKey = Trim(aTemp(i))

            If Not FnDicPi.exists(strKey) Then FnDicPi.Add strKey, strKey

        Else

            strKey = Trim(aTemp(i, iNbCln1))

            strItem = Trim(aTemp(i, iNbCln2))

            If Not FnDicPi.exists(strKey) Then FnDicPi.Add strKey, strItem

        End If

    Next 'j

    Set FnDicInAr = FnDicPi

End Function

'----------------------------------------------------------------------------------------------------

''http://www.planetaexcel.ru/forum/?PAGE_NAME=read&FID=8&TID=25891

''вообще-то верхняя граница может быть любой...( в том числе и отрицательной)

''я б сделал так:

 

Function RazmerArray(A) As Long

    Dim k As Long

    On Error GoTo KOH

    j = LBound(A)

    k = j '1

    While UBound(A, k) >= LBound(A, k)

        k = k + 1

    Wend

KOH:

    If k = 0 Then

        RazmerArray = 0

    Else

        RazmerArray = k - 1

    End If

End Function

''Sub test()

''    Dim Arr(4, 6, 3, 9)

''    For i = 1 To 60

''        On Error Resume Next

''        tmp = UBound(Arr, i)

''        If Err.Number > 0 Then MsgBox i - 1: Exit For:

''    Next

''End Sub

'====================================================================================================

 

 

 

 

 

'''вот вам мерседец :)

''

''Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Var() As Any) As Long

''Declare Sub GetMem4 Lib "msvbvm60.dll" (ByVal SrcPointer As Long, ByVal DstPointer As Long)

''

''Sub t()

''Dim ar(1, 2, 3, 4, 5, 6, 7)

''Dim p&, dm As Integer

''GetMem4 VarPtrArray(ar()), VarPtr(p)

''GetMem4 p, VarPtr(dm)

''

'''msgbox "вы объявили "& p "измерений"

''End Sub

''

''''а точнее( а главное безопаснее):

''

''Option Explicit

''Option Base 0

''Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Var() As Any) As Long

''Declare Sub GetMem4 Lib "msvbvm60.dll" (ByVal SrcPointer As Long, ByVal DstPointer As Long)

''

''Sub t()

''    Dim ar(1, 2, 3, 4, 5, 6, 7)

''    Dim p&, dm(1) As Integer

''    GetMem4 VarPtrArray(ar()), VarPtr(p)

''    GetMem4 p, VarPtr(dm(0))

''    MsgBox "вы объявили " & dm(0) & " измерений"

''End Sub

 

 

  

''Sub t()

''   Dim A '(1 To 1, 1 To 1)

''   Debug.Print RazmerArray(A)

''End Sub

''

''''а в мерседеце просто непосредственно берется значение размерности из соответствующей структуры - без всяких циклов..

''

''

''Private Function nDx%(Arr)   'возвращает количество измерений массива Arr

''  Dim i%, X

''  On Error GoTo eXX   ' увеличиваем i пока не получим ошибку попытки получить UBound по данному измерению

''  Do: i = i + 1: X = UBound(Arr, i): Loop

''eXX:    nDx = i - 1

''End Function