MS Excel

Musel by ste si urobiť ešte jednu pomocnú kolekciu s kľúčom a priradeným indexom, alebo rovno uložiť do kolekcie viacero info Array(index, hodnota) a hľadať kľúčom, alebo použiť jednu kolekciu, ale tu bude záležať na tom, čo potom potrebujete spraviť.

EDIT: Tu máte narýchlo všetky 3 spomenuté:
Sub KOLEKCE_LEZAKY()

Dim myCol_MAT As Collection
Set myCol_MAT = New Collection
Dim Oblast_MAT As Range
Dim myCol_INFO As Collection
Set myCol_INFO = New Collection
Dim Oblast_INFO As Range
Dim Cell As Range
Dim Item As Range
Dim MaxRow As Long
Dim i As Long

'Tvorba KOLEKCE z MAT
MaxRow = List1.Cells(Rows.Count, "D").End(xlUp).Row

Set Oblast_MAT = List1.Range("D4:D" & MaxRow)
For Each Cell In Oblast_MAT
i = i + 1
myCol_MAT.Add Array(Cell, i), CStr(Cell)
Next Cell

'Tvorba KOLEKCE z INFO
Set Oblast_INFO = List1.Range("E4:E" & MaxRow)
For Each Cell In Oblast_INFO
myCol_INFO.Add Cell
Next Cell

MsgBox myCol_INFO(myCol_MAT(CStr(List1.Range("I4")))(1))
End Sub
Sub KOLEKCE_LEZAKY2()

Dim myCol_MAT As Collection
Set myCol_MAT = New Collection
Dim Oblast_MAT As Range
Dim myCol_INFO As Collection
Set myCol_INFO = New Collection
Dim Oblast_INFO As Range
Dim Cell As Range
Dim Item As Range
Dim MaxRow As Long

'Tvorba KOLEKCE z MAT
MaxRow = List1.Cells(Rows.Count, "D").End(xlUp).Row

Set Oblast_MAT = List1.Range("D4:D" & MaxRow)
For Each Cell In Oblast_MAT
myCol_MAT.Add Array(Cell, Cell.Offset(0, 1)), CStr(Cell)
Next Cell

MsgBox myCol_MAT(CStr(List1.Range("I4")))(1)
End Sub
Sub KOLEKCE_LEZAKY3()

Dim myCol_MAT As Collection
Set myCol_MAT = New Collection
Dim Oblast_MAT As Range
Dim myCol_INFO As Collection
Set myCol_INFO = New Collection
Dim Oblast_INFO As Range
Dim Cell As Range
Dim Item As Range
Dim MaxRow As Long
Dim i As Long
Dim myCol_IDX As Collection
Set myCol_IDX = New Collection

'Tvorba KOLEKCE z MAT
MaxRow = List1.Cells(Rows.Count, "D").End(xlUp).Row

Set Oblast_MAT = List1.Range("D4:D" & MaxRow)
For Each Cell In Oblast_MAT
i = i + 1
myCol_IDX.Add i, CStr(Cell)
myCol_MAT.Add Cell
Next Cell

'Tvorba KOLEKCE z INFO
Set Oblast_INFO = List1.Range("E4:E" & MaxRow)
For Each Cell In Oblast_INFO
myCol_INFO.Add Cell
Next Cell

MsgBox myCol_INFO(myCol_IDX(CStr(List1.Range("I4"))))
End Subcitovat

elninoslov
DÍKY za pomoc, myslel jsem to trošičku jinak nenapsal jsem to moc stastne nicmene z tveho prikladu jsem si novou kolekci doupravil k dokonalosti.

DĚKUJI MOC za pomoc


Sub KOLEKCE_LEZAKY()

Dim myCol_MAT As Collection
Set myCol_MAT = New Collection
Dim Oblast_MAT As Range
Dim myCol_INFO As Collection
Set myCol_INFO = New Collection
Dim Oblast_INFO As Range
Dim myCol_FINAL As Collection
Set myCol_FINAL = New Collection
Dim Oblast_FINAL As Range
Dim Cell As Range
Dim Item As Range
Dim MaxRow As Long
Dim MaxRow2 As Long
Dim i As Long

MaxRow = List1.Cells(Rows.Count, "D").End(xlUp).Row
MaxRow2 = List1.Cells(Rows.Count, "I").End(xlUp).Row

'Tvorba KOLEKCE z MAT
Set Oblast_MAT = List1.Range("D4:D" & MaxRow)
For Each Cell In Oblast_MAT
i = i + 1
myCol_MAT.Add Array(Cell, i), CStr(Cell)
Next Cell

'Tvorba KOLEKCE z INFO
Set Oblast_INFO = List1.Range("E4:E" & MaxRow)
For Each Cell In Oblast_INFO
myCol_INFO.Add Cell
Next Cell

'Tvorba KOLEKCE FINAL
Set Oblast_FINAL = List1.Range("I4:I" & MaxRow2)
For Each Cell In Oblast_FINAL
myCol_FINAL.Add myCol_INFO(myCol_MAT(CStr(Cell))(1))
Next Cell

'Vypsání materiálů z kolekce
i = 0
For Each Item In myCol_FINAL
List1.Cells(i + 4, 10).Value = Item
i = i + 1
Next Item

End Subcitovat

*Omlouvám se poslal jsem špatnou přílohu posílám znovu..
*Zajímalo by mě jestli lze vysvětlit
Děkuji za radu citovat

elninoslov
joo to je přesně ono to mi nedošlo, nyní vidím když krokuji ze kolekce jsou nakrmene i po zmene vstupnich dat.

Jen mi to spadne ještě v této konečné části a netuším..
(Invalid procedure call or argument).

myCol_FINAL.Add myCol_INFO(myCol_MAT(CStr(Cell.Value))(1))citovat