Příspěvky uživatele

Zrovna tento netrval dlho, lebo ma princíp hneď trkol. Pár minút mi trvalo, kým som pochopil, že mi robia galibu tie medzery pri prevode textu na číslo. Škoda nemám stiahnutý ani Tvoj ani lugr-ov súbor, že by som si pozrel čas, tak iba tipujem 10-15-20 min? Aj s vyskúšaním. Niekedy to býva ale podstatne väčšie utrpenie, kým sa človek nakoniec dopracuje často aj k jednoduchému riešeniu. Vieš ako to býva, "Pre stromy nevidno les".

EDIT: PS: Áno vyhodnotenie vzorca je úplná tragédia. Také okno mohlo mať opodstatnenie v dobách VGA rozlíšenia, a nie FHD/4K... Nemá niekto nejakú featurku ako to zväčšiť?
Inak v bunke alebo v riadku vzorcov sa dá vyhodnotiť označená časť vzorca pomocou F9.

Makro som ešte nespustil, urobím najskôr hypotézu. Vy priraďujete do kolekcie bunky (Cell), nie hodnoty. Keď kolekciu potom čítate, v kolekcii je uložená bunka, nie hodnota. Hodnotu Vy v polke makra zmeníte, a potom z tej bunky v kolekcii prečítate hodnotu. No akú má mať asi hodnotu? Správne - tú novú.
Skúste priradiť do kolekcie Cell.Value či mám pravdu...

Pre blbca ??? To nemyslíte Vážne! Vy ste práveže šikula. Alebo si tykajme. Nehnevaj sa za katastro-formu ako som to popísal, ale už fakt ponáhľam spať. Takže nekameňovať pls :). Dúfam, že je takto pochopiteľný aj vzorec aj prečo som zmenil to A1 za B1.
Ten vzorec sa dá ešte zjednodušiť vynechaním ISNUMBER a hľadať sa v MATCH nebude TRUE ale nejaké obrovské číslo 9E+307 a tretí parameter bude 1.

EDIT:
@marjankaj : však som aj písal minule, čo mi všetko je, že som chorý

A ešte som zabudol na variant, že to čo dávate do kolekcie MAT bude vyhľadávací kľúč v INFO:
Sub KOLEKCE_LEZAKY4()

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 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, CStr(Cell.Offset(0, -1))
Next Cell

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

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 Sub

To radšej nie, aby som nezostal namyslený, prípadná chyba potom o to viacej bolí

Upravený aj vzorec v rozbaľovacom zozname, aj vzorec v ANO/NE.

Inak zdroj upravený na Váš prípad. Pitvať ten vzorec nebudem.

Ak použijete maticové vzorce, nemusíte mať tú prevodnú tabuľku, len 1 pomocný stĺpec.
Mená zapisujte bez medzery na konci. Matica si to spojí. Urobí zoznam bez medzier. Rozbaľovací zoznam berie iba vyplnené, a ďalšia matica počíta overenie na základe podmienok.
Pr.

Spodný dátum "poučení" netreba kontrolovať? Teda nemôže nastať, že bude napr. naplánované poučenie do budúcna na nejaký dátum? Je to vždy len minulý alebo dnešný dátum?

Tá medzitabuľka H2J16 je potrebná? Nestačí iba 1 pomocný/skrytý spájajúci stĺpec v prvotnej tabuľke?

Medzi menami sú medzery, a teda netreba urobiť výberový zoznam bez medzier? To by sa urobilo v tom istom spomínanom pomocnom stĺpci.

Teraz, takto ako to máte to bude:
=IF(COUNTIFS($I$3:$I$16;I22;$D$3:$D$16;"<="&G22;$E$3:$E$16;">="&G22);"ANO";"NE")
=KDYŽ(COUNTIFS($I$3:$I$16;I22;$D$3:$D$16;"<="&G22;$E$3:$E$16;">="&G22);"ANO";"NE")
ak budete zadávať dátum iba do prvej bunky z trojice, tak musí byť namiesto ...&G22... toto ...&$G$22... pre prvú trojicu, ...&$G$27... pre druhú trojicu atď.

??? Mojej procedúre nič nepredchádza. Nič na vytváranie listov tam mimo mojej proc. nie je. A ak na to máte inú proc. (tá "rozkopiruj1" to nerobí), ktorú ste neuviedol, tak to nie je moja chyba.
PS: Pozerám, že som tam zabudol nepotrebný Module1 - zmažte.

Ak tam to vytváranie byť nemá, tak ten spodný cyklus
For y = 1 To UBound(arrZodp, 1)
On Error Resume Next
Set WS = Worksheets(arrZodp(y, 1))
On Error GoTo 0
If WS Is Nothing Then
Set WS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
WS.Name = arrZodp(y, 1)
Else
WS.Activate
WS.UsedRange.Delete
End If

Worksheets("Data").UsedRange.Rows(1).Copy
With WS
.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).Select
.Cells(2, 1).Resize(arrPocty(y, 1), Sloupcu).Value = AIZ(y)(1)
End With
Set WS = Nothing
Next y
nahraďte takýmto
For y = 1 To UBound(arrZodp, 1)
Worksheets(arrZodp(y, 1)).Cells(2, 1).Resize(arrPocty(y, 1), Sloupcu).Value = AIZ(y)(1)
Next y
a zmažte deklaráciu na konci prvého riadku
, WS As Worksheet

A ten Rýchly filter ste neskúšal? Označte si celú tbl Data, Ctrl+T, nechajte zaškrtnuté že obsahuje hlavičky, v menu Návrh vyberte Vložiť rýchly filter, vyberte Zodpovídá, OK. A teraz kliknutím na meno sa tbl vyfiltruje, prípadne si môžete zapnúť hore aj viacnásobný výber. Ak nevyhovuje tak nič.

Žgrlíte na prílohe, a teda nám to zťažujete, tak som Vám to aj ja sťažil, nezmyselným popremieňaním zadania.

Pokus makro rozkopiruj2 :
Pozor, polka kódu je tam na vytváranie neexistujúcich listov, kontrolu a mazanie dát na existujúcich listoch.
Vyskúšajte, popis urobím dodatočne.

Inak prečo nepoužijete v liste Data objekt Tabuľka a na ňu Rýchly filter (SmartFilter)? Ten bude mať jedinečné hodnoty priamo, a každé meno máte hneď na 1 klik.

Pr.
Sub HideColumns()
Dim R As Long, HD(), DD(), rngHide As Range, rngShow As Range
With Worksheets("Hide")
R = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If R = 0 Then Exit Sub
HD = .Cells(2, 1).Resize(R, 2).Value
End With

With Worksheets("Data").ListObjects("Tabulka1").HeaderRowRange
DD = .Value
On Error GoTo CHYBA
For R = 1 To UBound(HD, 1)
If HD(R, 2) = "Ano" Then
If rngHide Is Nothing Then Set rngHide = .Columns(Application.Match(HD(R, 1), DD, 0)) Else Set rngHide = Union(rngHide, .Columns(Application.Match(HD(R, 1), DD, 0)))
Else
If rngShow Is Nothing Then Set rngShow = .Columns(Application.Match(HD(R, 1), DD, 0)) Else Set rngShow = Union(rngShow, .Columns(Application.Match(HD(R, 1), DD, 0)))
End If
Next R
End With

If Not rngHide Is Nothing Then rngHide.EntireColumn.Hidden = True
If Not rngShow Is Nothing Then rngShow.EntireColumn.Hidden = False

CHYBA:
If Err.Number <> 0 Then MsgBox "Nastala chyba. Napr. niektoré meno sa nenašlo.", vbCritical
End Sub

Tak na rýchlo tá verzia s poľom:
Option Explicit
Function ColorMath(InputRange As Range, ReferenceCellColor As Range, Optional Action As String = "S", Optional ConditionalRange As Range, Optional ConditionalValue)
' Action can be S to SUM, A to AVERAGE, or C to COUNT
' If not specified the default Action is SUM

Dim aInput(), aCR()
Dim bIsConditional As Boolean, x As Integer, y As Long, bIsOK As Boolean
Dim Cell As Range, ReferenceColor As Long, CellCount As Long, Result As Variant

Application.Volatile 'Automatické přepočítání při jakékoliv změně v buňkách

If InputRange.Cells.Count = 1 Then 'Načtení hodnot z buněk kontrolované oblasti do pole
ReDim aInput(1 To 1, 1 To 1)
aInput(1, 1) = InputRange.Value
Else
aInput = InputRange.Value
End If

If Not ConditionalRange Is Nothing Then 'Zjištění přítomnosti další podmínky
bIsConditional = True
If ConditionalRange.Rows.Count = 1 Then 'Načtení hodnot z buněk oblasti další podmínky do pole
ReDim aCR(1 To 1, 1 To 1)
aCR(1, 1) = ConditionalRange.Columns(1).Value
Else
aCR = ConditionalRange.Columns(1).Value
End If
End If

Action = UCase(Action) 'Konverze zadaného typu výpočtu do upercase
Result = 0
CellCount = 0
ReferenceColor = ReferenceCellColor.Interior.Color 'Zadefinování proměnné pro referenční barvu

For y = 1 To UBound(aInput, 1)
For x = 1 To UBound(aInput, 2)
If InputRange.Cells(y, x).Interior.Color = ReferenceColor Then 'Kontrola barvy
bIsOK = True 'Barva sedí, zatím je to OK
If bIsConditional Then bIsOK = aCR(y, 1) = ConditionalValue 'Když je další podmínka, zkontroluj a uprav OK/NOK
If bIsOK Then 'Když je to OK i po další podmínce
CellCount = CellCount + 1 'Inkrementace Počet (potřebné pro COUNT i AVERAGE)
Select Case Action
Case "A", "S": Result = Result + aInput(y, x) 'A když se jedná o AVERAGE nebo SUM, tak připrav součet
End Select
End If
End If
Next x
Next y

If CellCount > 0 Then 'Máme na konci nějaké OK?
Select Case Action
Case "A": Result = Result / CellCount 'Typ výpočtu pro AVERAGE
Case "C": Result = CellCount 'Typ výpočtu pro COUNT
End Select 'Typ výpočtu pro SUM už je hotov v předešlým cyklu
End If

ColorMath = Result
End Function

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje