• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

Příspěvky uživatele

??? 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.

Opačné lomítka a zlý zložený odkaz.

Prerobil som to na jednoduché parametrizovanie. Na začiatku vidíte 3 riadiace premenné. Význam je jasný. Urobil som aký-taký popis makra.
Ak zadáte parametre 4, 4, AS, funguje na novú tbl.
Ak zadáte 2, 3, A funguje na starú tbl.

Private Sub Workbook_Open()
Dim R As Long, D(), V() As String, S As String, Sprava As String, Smeny(), PocetSmen As Byte, SloupecMesice As String, Skok As Byte

PocetSmen = 4 'Počet směn
Skok = 4 'Počet řádků na měsíc
SloupecMesice = "AS" 'Sloupec s názvem měsíce

With ThisWorkbook.Worksheets("List1")
R = .Cells(Rows.Count, SloupecMesice).Offset(0, 1).End(xlUp).Row 'Počet řádků dat se určí ze sloupce vpravo od sloupce měsíců
D = .Cells(1, SloupecMesice).Resize(R, 3).Value 'Načíst 3 sloupce dat
Smeny = .Cells(1, SloupecMesice).Offset(0, 1).Resize(PocetSmen).Value 'Názvy směn se berou z prvního měsíce
End With
ReDim V(UBound(D, 1) - 1) 'Príprava výsledkového pole

For R = 1 To R 'Projdi všechny řádky dat, jestli jsou plné, podle skoku zjisti název mesíce pro danou N-tici, a vyskloňuj
If D(R, 3) > 0 Then V(R - 1) = vbTab & D(R, 2) & D(((R - 1) \ Skok) * Skok + 1, 1) & vbTab & D(R, 3) & IIf(D(R, 3) = 1, " plná směna", IIf(D(R, 3) < 5, " plné směny", " plných směn"))
Next R

For R = 1 To PocetSmen 'Opakuj filtr na výsledkové pole pro každou směnu
S = Replace(Join(Filter(V, Smeny(R, 1), True), vbCrLf), Smeny(R, 1), "") 'Vyfiltruje výsledek na danou směnu, vymaže její název
If LenB(S) > 0 Then Sprava = Sprava & IIf(LenB(Sprava) = 0, "", vbCrLf & vbCrLf) & Smeny(R, 1) & ":" & vbCrLf & S 'Když něco zústane, přidá to k předešlé správě
Next R

If Sprava <> "" Then MsgBox Sprava, vbExclamation, "Přehled plných směn." 'Když máme nějakou komplexní správu, tak ji vypiš
End Sub

Založte tému a priložte súbor.

EDIT: 10.1.2021 13:49
Tu je príklad na trojitý previazaný výberový zoznam. Riešení je viacero, rozhodne to nie je jediné ani najsprávnejšie riešenie. Záleží na tom, ako máte štruktúrované zdrojové údaje, a ako to zamýšľate používať.
Trojitý previazaný výberový zoznam.xlsx

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse