Příspěvky uživatele
< návrat zpět
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.
Pozrite sa počas zastaveného kódu do kolekcie Shapes na jednotlivé Item a v ich vlastnostiach podľa položky ALternativeText (nápis na tlačítku) pozrite položku Name.
Worksheets("Faktura").Shapes
Sub Save_Sheet_As_Workbook()
Dim NazovSuboru As String, E As Long
With Worksheets("Nastaveni")
NazovSuboru = .Range("F3") & "\" & .Range("F1") & .Range("H1") & ".xlsx"
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo CHYBA
Worksheets("Faktura").Copy
With ActiveWorkbook
With .ActiveSheet
.Shapes("Button 1").Delete
.Shapes("Button 2").Delete
.UsedRange.Value = .UsedRange.Value
End With
.SaveAs NazovSuboru, xlOpenXMLWorkbook
.Close False
End With
E = vbInformation
GoTo POKRACUJ
CHYBA:
E = vbCritical
POKRACUJ:
MsgBox IIf(E = vbCritical, "Nastala chyba", "Uloženo"), E
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Podmienený formát
To B1 som tam dal naschvál aby To nelákalo meniť aj to $A$1, čo je iba pomoc pre vytvorenie poľa čísiel.
Ak je EAN z 13-ich po sebe idúcich čísel, tak maticový vzorec:
=IFERROR(MID(B1;MATCH(TRUE;ISNUMBER(--MID(SUBSTITUTE(B1;" ";"@");ROW(OFFSET($A$1;;;LEN(B1)-12));13));0);13);"")
=IFERROR(ČÁST(B1;POZVYHLEDAT(PRAVDA;JE.ČISLO(--ČÁST(DOSADIT(B1;" ";"@");ŘÁDEK(POSUN($A$1;;;DÉLKA(B1)-12));13));0);13);"")
Inak ak Vám dáva tie čiastkové cesty nejaký automatický systém, tak to potom v tom vzorci nahradzujte, namiesto ...C3... dajte
...SUBSTITUTE(C3;"/";"\")...
...DOSADIT(A1;"/";"\")(C3;"/";"\")...
alebo jednorázovo cez Nahradiť (Ctrl+H), záleží na tom, ako často to potrebujete.
Najlepšie, ak by sa dal tak nastaviť export toho zdroja.
Uživatelské menu
\nMenu
Formulář 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