Příspěvky uživatele
< návrat zpět
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
Nepočítajte s celými stĺpcami, radšej ich vypočítajte.
=ColorMath(OFFSET(Vše!$A$2;;MATCH(B$1;Vše!$1:$1;0)-1;COUNTA(Vše!$A:$A)-1);$K$1;"S";OFFSET(Vše!$F$2;;;COUNTA(Vše!$A:$A)-1);$A2)
=ColorMath(POSUN(Vše!$A$2;;POZVYHLEDAT(B$1;Vše!$1:$1;0)-1;POČET2(Vše!$A:$A)-1);$K$1;"S";POSUN(Vše!$F$2;;;POČET2(Vše!$A:$A)-1);$A2)
Nechce sa mi overovať, ale tipujem, že tom Cell.Offset(0, -11) alebo v tom Cells(Cell.Row, 6) nepočítate s listom dát, ale s listom súhrnu, páč je to volané z neho.
Kód +- autobus ... :
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 bIsConditional As Boolean, i 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
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
bIsConditional = Not ConditionalRange Is Nothing 'Zjištění přítomnosti další podmínky
For Each Cell In InputRange
i = i + 1 'Index pro další podmínku
If Cell.Interior.Color = ReferenceColor Then 'Kontrola barvy
bIsOK = True 'Barva sedí, zatím je to OK
If bIsConditional Then bIsOK = ConditionalRange(i).Value = 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 + Cell.Value 'A když se jedná o AVERAGE nebo SUM, tak připrav součet
End Select
End If
End If
Next Cell
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
Keď sa mi bude chcieť, urobím aj verziu s poľom dát, možno bude rýchlejšia. Farbu bude treba bunku po bunke kontrolovať, to je jasné, ale hodnotu bunky a podmienku už by si načítal z poľa.
Fúha, no neviem, či to nebude verziou Excelu. Ja mám E2019 a fičí to. Skúste nemať tie makrá na tie 2 čudlíky v liste Faktura, ale v module. Aj keď u mňa je to jedno.
Uživatelské menu
\nFormulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články