Vba excel ассоциативный массив

Here we go… just copy the code to a module, it’s ready to use

Private Type hashtable
    key As Variant
    value As Variant
End Type

Private GetErrMsg As String

Private Function CreateHashTable(htable() As hashtable) As Boolean
    GetErrMsg = ""
    On Error GoTo CreateErr
        ReDim htable(0)
        CreateHashTable = True
    Exit Function

CreateErr:
    CreateHashTable = False
    GetErrMsg = Err.Description
End Function

Private Function AddValue(htable() As hashtable, key As Variant, value As Variant) As Long
    GetErrMsg = ""
    On Error GoTo AddErr
        Dim idx As Long
        idx = UBound(htable) + 1

        Dim htVal As hashtable
        htVal.key = key
        htVal.value = value

        Dim i As Long
        For i = 1 To UBound(htable)
            If htable(i).key = key Then Err.Raise 9999, , "Key [" & CStr(key) & "] is not unique"
        Next i

        ReDim Preserve htable(idx)

        htable(idx) = htVal
        AddValue = idx
    Exit Function

AddErr:
    AddValue = 0
    GetErrMsg = Err.Description
End Function

Private Function RemoveValue(htable() As hashtable, key As Variant) As Boolean
    GetErrMsg = ""
    On Error GoTo RemoveErr

        Dim i As Long, idx As Long
        Dim htTemp() As hashtable
        idx = 0

        For i = 1 To UBound(htable)
            If htable(i).key <> key And IsEmpty(htable(i).key) = False Then
                ReDim Preserve htTemp(idx)
                AddValue htTemp, htable(i).key, htable(i).value
                idx = idx + 1
            End If
        Next i

        If UBound(htable) = UBound(htTemp) Then Err.Raise 9998, , "Key [" & CStr(key) & "] not found"

        htable = htTemp
        RemoveValue = True
    Exit Function

RemoveErr:
    RemoveValue = False
    GetErrMsg = Err.Description
End Function

Private Function GetValue(htable() As hashtable, key As Variant) As Variant
    GetErrMsg = ""
    On Error GoTo GetValueErr
        Dim found As Boolean
        found = False

        For i = 1 To UBound(htable)
            If htable(i).key = key And IsEmpty(htable(i).key) = False Then
                GetValue = htable(i).value
                Exit Function
            End If
        Next i
        Err.Raise 9997, , "Key [" & CStr(key) & "] not found"

    Exit Function

GetValueErr:
    GetValue = ""
    GetErrMsg = Err.Description
End Function

Private Function GetValueCount(htable() As hashtable) As Long
    GetErrMsg = ""
    On Error GoTo GetValueCountErr
        GetValueCount = UBound(htable)
    Exit Function

GetValueCountErr:
    GetValueCount = 0
    GetErrMsg = Err.Description
End Function

To use in your VB(A) App:

Public Sub Test()
    Dim hashtbl() As hashtable
    Debug.Print "Create Hashtable: " & CreateHashTable(hashtbl)
    Debug.Print ""
    Debug.Print "ID Test   Add V1: " & AddValue(hashtbl, "Hallo_0", "Testwert 0")
    Debug.Print "ID Test   Add V2: " & AddValue(hashtbl, "Hallo_0", "Testwert 0")
    Debug.Print "ID Test 1 Add V1: " & AddValue(hashtbl, "Hallo.1", "Testwert 1")
    Debug.Print "ID Test 2 Add V1: " & AddValue(hashtbl, "Hallo-2", "Testwert 2")
    Debug.Print "ID Test 3 Add V1: " & AddValue(hashtbl, "Hallo 3", "Testwert 3")
    Debug.Print ""
    Debug.Print "Test 1 Removed V1: " & RemoveValue(hashtbl, "Hallo_1")
    Debug.Print "Test 1 Removed V2: " & RemoveValue(hashtbl, "Hallo_1")
    Debug.Print "Test 2 Removed V1: " & RemoveValue(hashtbl, "Hallo-2")
    Debug.Print ""
    Debug.Print "Value Test 3: " & CStr(GetValue(hashtbl, "Hallo 3"))
    Debug.Print "Value Test 1: " & CStr(GetValue(hashtbl, "Hallo_1"))
    Debug.Print ""
    Debug.Print "Hashtable Content:"

    For i = 1 To UBound(hashtbl)
        Debug.Print CStr(i) & ": " & CStr(hashtbl(i).key) & " - " & CStr(hashtbl(i).value)
    Next i

    Debug.Print ""
    Debug.Print "Count: " & CStr(GetValueCount(hashtbl))
End Sub

Источник

Друзья, на VBA писать только начинаю, пока не разобрался, но голову ломаю несколько дней  :)

Мне необходимо производить манипуляции с таблицей данных, где в строках некий набор записей, а в столбцах различные подзаписи (типа «продавец», «продукт», «цена»…), то есть налицо двумерный массив. Очень хочется обращаться с этим массивом, как с ассоциативным.
Примерно так

Код 
a[1][key1] = "abc"
a[1][key2] = 2
....
a[N][keyM] = "smth"

Таким образом к элементам массива удобно обращаться по ключам, складывать, вычитать и тд.
Наверняка в VBA есть решение, но для меня оно не открывается.

Что я изучил:

Collection, scripting.dictionary — не подходит, поскольку на один ключ там только одно значение (если я всё правильно понял)
Пользовательский тип данных — не подходит, поскольку набор колонок может меняться от раза к разу (как задавать тип данных динамически, я не нашёл)

Что приходит на ум:

1. Создать двумерный массив (просто скопировать таблицу в массив) вместе с названиями столбцов. Таким образом в первой строке массива у меня будет массив с названиями полей. И когда мне нужно будет обратиться к элементу a[345876][«Продукт»], то я буду искать в первой строке порядковый номер элемента с названием «Продукт»
примерно так

Код 
for i=1 to a[1].Count
if aa == "Продукт" then exit For
Next' a[345876][i]      ' будет искомым элементом двумерного массива

2. Создать коллекцию массивов и проделать примерно тоже самое. Чем это лучше или хуже не знаю, то мне кажется, это будет одно и тоже.
3. Создать отдельную коллекцию типа ColNames(value=’номер элемента’ key=’имя колонки’). Тогда к элементу a[345876][«Продукт»] можно будет обратиться таким образом a[345876][ColNames.Item(«Продукт»  ;)  ]

Но всё это, как мне кажется, кривые способы. Наверняка, есть красивое решение для такого рода задач.

Как вообще выглядит моя задача, точнее её часть:
1.У меня есть таблица, которую я копирую из другого файла. Строк в таблице десятки тысяч, столбцов — десятки (количество столбцов и их названия могут меняться от раза к разу)
Таблица примерно такого вида

Клиент продукт объём штуки Сумма
k003382 pr098782 45 -20 94.4
k084982 pr98376 98 87 -9837
k084982 pr98346 -34 874.2 -35
k084876 pr98346 45 7636 7736

2.Я формирую из комбинации значений нескольких столбцов столбец с ключом, который пока не является уникальным.
3. сортирую таблицу по пока не уникальному ключу
4. формирую массив уникальных ключей (убираю дубликаты)
5. далее нужно суммировать числовые столбцы по уникальному ключу. (это вполне решается прописыванием формул типа суммесли(…), но считает такой объем данных очень долго.
6. дальше нужно будет производить другие операции, но это уже другая история.

Возможно есть способ одновременного формирования списка уникальных ключей и суммирования строк с повторными ключами. Пока я формирую список ключей просто через .RemoveDuplicates

И так финальные вопросы:
1. Как создать такую структуру данных (массив, коллекцию… что угодно), чтобы можно было обращаться по принципу двухмерного ассоциативного массива.
2. Как удалить дубликаты в столбце «A» одновременным суммированием числовых значений в столбцах «D», «E»… там где значения столбца А повторяются.

Буду признателен за любые советы и конструктивную критику

Источник

Здесь мы идем… просто скопируем код в модуль, он готов использовать

Private Type hashtable
    key As Variant
    value As Variant
End Type

Private GetErrMsg As String

Private Function CreateHashTable(htable() As hashtable) As Boolean
    GetErrMsg = ""
    On Error GoTo CreateErr
        ReDim htable(0)
        CreateHashTable = True
    Exit Function

CreateErr:
    CreateHashTable = False
    GetErrMsg = Err.Description
End Function

Private Function AddValue(htable() As hashtable, key As Variant, value As Variant) As Long
    GetErrMsg = ""
    On Error GoTo AddErr
        Dim idx As Long
        idx = UBound(htable) + 1

        Dim htVal As hashtable
        htVal.key = key
        htVal.value = value

        Dim i As Long
        For i = 1 To UBound(htable)
            If htable(i).key = key Then Err.Raise 9999, , "Key [" & CStr(key) & "] is not unique"
        Next i

        ReDim Preserve htable(idx)

        htable(idx) = htVal
        AddValue = idx
    Exit Function

AddErr:
    AddValue = 0
    GetErrMsg = Err.Description
End Function

Private Function RemoveValue(htable() As hashtable, key As Variant) As Boolean
    GetErrMsg = ""
    On Error GoTo RemoveErr

        Dim i As Long, idx As Long
        Dim htTemp() As hashtable
        idx = 0

        For i = 1 To UBound(htable)
            If htable(i).key <> key And IsEmpty(htable(i).key) = False Then
                ReDim Preserve htTemp(idx)
                AddValue htTemp, htable(i).key, htable(i).value
                idx = idx + 1
            End If
        Next i

        If UBound(htable) = UBound(htTemp) Then Err.Raise 9998, , "Key [" & CStr(key) & "] not found"

        htable = htTemp
        RemoveValue = True
    Exit Function

RemoveErr:
    RemoveValue = False
    GetErrMsg = Err.Description
End Function

Private Function GetValue(htable() As hashtable, key As Variant) As Variant
    GetErrMsg = ""
    On Error GoTo GetValueErr
        Dim found As Boolean
        found = False

        For i = 1 To UBound(htable)
            If htable(i).key = key And IsEmpty(htable(i).key) = False Then
                GetValue = htable(i).value
                Exit Function
            End If
        Next i
        Err.Raise 9997, , "Key [" & CStr(key) & "] not found"

    Exit Function

GetValueErr:
    GetValue = ""
    GetErrMsg = Err.Description
End Function

Private Function GetValueCount(htable() As hashtable) As Long
    GetErrMsg = ""
    On Error GoTo GetValueCountErr
        GetValueCount = UBound(htable)
    Exit Function

GetValueCountErr:
    GetValueCount = 0
    GetErrMsg = Err.Description
End Function

Для использования в приложении VB (A):

Public Sub Test()
    Dim hashtbl() As hashtable
    Debug.Print "Create Hashtable: " & CreateHashTable(hashtbl)
    Debug.Print ""
    Debug.Print "ID Test   Add V1: " & AddValue(hashtbl, "Hallo_0", "Testwert 0")
    Debug.Print "ID Test   Add V2: " & AddValue(hashtbl, "Hallo_0", "Testwert 0")
    Debug.Print "ID Test 1 Add V1: " & AddValue(hashtbl, "Hallo.1", "Testwert 1")
    Debug.Print "ID Test 2 Add V1: " & AddValue(hashtbl, "Hallo-2", "Testwert 2")
    Debug.Print "ID Test 3 Add V1: " & AddValue(hashtbl, "Hallo 3", "Testwert 3")
    Debug.Print ""
    Debug.Print "Test 1 Removed V1: " & RemoveValue(hashtbl, "Hallo_1")
    Debug.Print "Test 1 Removed V2: " & RemoveValue(hashtbl, "Hallo_1")
    Debug.Print "Test 2 Removed V1: " & RemoveValue(hashtbl, "Hallo-2")
    Debug.Print ""
    Debug.Print "Value Test 3: " & CStr(GetValue(hashtbl, "Hallo 3"))
    Debug.Print "Value Test 1: " & CStr(GetValue(hashtbl, "Hallo_1"))
    Debug.Print ""
    Debug.Print "Hashtable Content:"

    For i = 1 To UBound(hashtbl)
        Debug.Print CStr(i) & ": " & CStr(hashtbl(i).key) & " - " & CStr(hashtbl(i).value)
    Next i

    Debug.Print ""
    Debug.Print "Count: " & CStr(GetValueCount(hashtbl))
End Sub
Источник

мы идем… просто скопируйте код в модуль, он готов к использованию

Private Type hashtable
    key As Variant
    value As Variant
End Type

Private GetErrMsg As String

Private Function CreateHashTable(htable() As hashtable) As Boolean
    GetErrMsg = ""
    On Error GoTo CreateErr
        ReDim htable(0)
        CreateHashTable = True
    Exit Function

CreateErr:
    CreateHashTable = False
    GetErrMsg = Err.Description
End Function

Private Function AddValue(htable() As hashtable, key As Variant, value As Variant) As Long
    GetErrMsg = ""
    On Error GoTo AddErr
        Dim idx As Long
        idx = UBound(htable) + 1

        Dim htVal As hashtable
        htVal.key = key
        htVal.value = value

        Dim i As Long
        For i = 1 To UBound(htable)
            If htable(i).key = key Then Err.Raise 9999, , "Key [" & CStr(key) & "] is not unique"
        Next i

        ReDim Preserve htable(idx)

        htable(idx) = htVal
        AddValue = idx
    Exit Function

AddErr:
    AddValue = 0
    GetErrMsg = Err.Description
End Function

Private Function RemoveValue(htable() As hashtable, key As Variant) As Boolean
    GetErrMsg = ""
    On Error GoTo RemoveErr

        Dim i As Long, idx As Long
        Dim htTemp() As hashtable
        idx = 0

        For i = 1 To UBound(htable)
            If htable(i).key <> key And IsEmpty(htable(i).key) = False Then
                ReDim Preserve htTemp(idx)
                AddValue htTemp, htable(i).key, htable(i).value
                idx = idx + 1
            End If
        Next i

        If UBound(htable) = UBound(htTemp) Then Err.Raise 9998, , "Key [" & CStr(key) & "] not found"

        htable = htTemp
        RemoveValue = True
    Exit Function

RemoveErr:
    RemoveValue = False
    GetErrMsg = Err.Description
End Function

Private Function GetValue(htable() As hashtable, key As Variant) As Variant
    GetErrMsg = ""
    On Error GoTo GetValueErr
        Dim found As Boolean
        found = False

        For i = 1 To UBound(htable)
            If htable(i).key = key And IsEmpty(htable(i).key) = False Then
                GetValue = htable(i).value
                Exit Function
            End If
        Next i
        Err.Raise 9997, , "Key [" & CStr(key) & "] not found"

    Exit Function

GetValueErr:
    GetValue = ""
    GetErrMsg = Err.Description
End Function

Private Function GetValueCount(htable() As hashtable) As Long
    GetErrMsg = ""
    On Error GoTo GetValueCountErr
        GetValueCount = UBound(htable)
    Exit Function

GetValueCountErr:
    GetValueCount = 0
    GetErrMsg = Err.Description
End Function

для использования в вашем приложении VB(A):

Public Sub Test()
    Dim hashtbl() As hashtable
    Debug.Print "Create Hashtable: " & CreateHashTable(hashtbl)
    Debug.Print ""
    Debug.Print "ID Test   Add V1: " & AddValue(hashtbl, "Hallo_0", "Testwert 0")
    Debug.Print "ID Test   Add V2: " & AddValue(hashtbl, "Hallo_0", "Testwert 0")
    Debug.Print "ID Test 1 Add V1: " & AddValue(hashtbl, "Hallo.1", "Testwert 1")
    Debug.Print "ID Test 2 Add V1: " & AddValue(hashtbl, "Hallo-2", "Testwert 2")
    Debug.Print "ID Test 3 Add V1: " & AddValue(hashtbl, "Hallo 3", "Testwert 3")
    Debug.Print ""
    Debug.Print "Test 1 Removed V1: " & RemoveValue(hashtbl, "Hallo_1")
    Debug.Print "Test 1 Removed V2: " & RemoveValue(hashtbl, "Hallo_1")
    Debug.Print "Test 2 Removed V1: " & RemoveValue(hashtbl, "Hallo-2")
    Debug.Print ""
    Debug.Print "Value Test 3: " & CStr(GetValue(hashtbl, "Hallo 3"))
    Debug.Print "Value Test 1: " & CStr(GetValue(hashtbl, "Hallo_1"))
    Debug.Print ""
    Debug.Print "Hashtable Content:"

    For i = 1 To UBound(hashtbl)
        Debug.Print CStr(i) & ": " & CStr(hashtbl(i).key) & " - " & CStr(hashtbl(i).value)
    Next i

    Debug.Print ""
    Debug.Print "Count: " & CStr(GetValueCount(hashtbl))
End Sub
Источник

So I set my sheet up like this:

enter image description here

Then using the following code I loaded the array and cycled through each line in the array. I added the Hours as they met the condition and displayed the result in the immediate window.

Edit: As far as I know excel does not use column names. So the only way I could come up with is this, Where we add the first row into the array then cycle through them looking for the names in the first row of the array to get the position of that column then use the variable to find again.

A quicker method would likely be an advanced filter with subtotals. Filter on a different page than the data. Or, the best answer would be using a pivot table.

Sub nubuk()

Dim arr() As Variant
Dim smTtl As Double
Dim i&
Dim lastrow As Long
Dim lastcolumn
Dim t&
Dim cntry&, stus&, hrs&

With ActiveSheet
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastcolumn = Cells(1, .Columns.Count).End(xlToLeft).Column
    Debug.Print lastcolumn
    arr = .Range(.Cells(1, 1), .Cells(lastrow, lastcolumn)).Value
End With
For t = 1 To lastcolumn
    Select Case LCase(arr(1, t))
        Case "country"
            cntry = t
        Case "training status"
            stus = t
        Case "training hours"
            hrs = t
        Case Else
    End Select
Next t
For i = LBound(arr, 1) To UBound(arr, 1)
    If arr(i, cntry) = "USA" And arr(i, stus) = "Completed" Then
        smTtl = smTtl + arr(i, hrs)
    End If
Next

Debug.Print smTtl

End Sub

Источник

Понравилась статья? Поделить с друзьями:

А вот еще интересные статьи:

  • Vba excel аналог функции или
  • Vba excel аналог поиск
  • Vba excel активная ячейка это
  • Vba excel активная ячейка на листе
  • Vba excel xldown range

    • 0 0 голоса
    Рейтинг статьи
    Подписаться
    Уведомить о
    guest

    0 комментариев
    Старые
    Новые Популярные
    Межтекстовые Отзывы
    Посмотреть все комментарии