MyTetra Share
Делитесь знаниями!
словарь из двумерного(Одномерного) массива
28.11.2017
15:25
Текстовые метки: dic, array, размер массива
Раздел: VBA - Dictionary

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


 
MyTetra Share v.0.52
Яндекс индекс цитирования