Příspěvky uživatele

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

Ak to dobre chápem, tak takto ???
Sub pokus()
ZmenaCiary Worksheets("Hárok1").Shapes("Straight Connector 2"), 40, 40, 90, 60
ZmenaCiary Worksheets("Hárok1").Shapes("Straight Connector 4"), 90, 60, 100, 160
End Sub

Sub ZmenaCiary(ByRef Ciara As Shape, X1 As Single, Y1 As Single, X2 As Single, Y2 As Single)
With Ciara
.Left = X1
.Top = Y1
.Width = X2 - X1
.Height = Y2 - Y1
End With
End Sub

Nemci majú Tag, teda skúste "tttt"

Vyskúšajte niečo takéto
=PROPER(IF(TEXT(D4;"[$-407]tttt")="tttt";TEXT(D4;"[$-407]dddd");TEXT(D4;"[$-407]tttt")))
=VELKÁ2(KDYŽ(HODNOTA.NA.TEXT(D4;"[$-407]tttt")="tttt";HODNOTA.NA.TEXT(D4;"[$-407]dddd");HODNOTA.NA.TEXT(D4;"[$-407]tttt")))
Teda skúsi najskôr nemecké označenie dňa, a ak dostane "tttt" tak to nemecký Office nieje, a skúsi označenie dňa "dddd" ktoré je v CZ, SK, EN a mnohých ďalších.

Môžete vyskúšať aj rýchlejší variant, kód je ale ťažší:
Sub Makro()
Dim WS As Worksheet, i As Integer, D(), rng As Range
For Each WS In ThisWorkbook.Worksheets
Select Case WS.Name
Case "Leden", "Únor", "Březen", "Duben", "Květen", "Červen", "Červenec", "Srpen", "Září", "Říjen", "Listopad", "Prosinec":
D = WS.Range("D4:AH4").Value
For i = 1 To 31
If LenB(D(1, i)) <> 0 Then
If Weekday(D(1, i), vbMonday) > 5 Then If rng Is Nothing Then Set rng = WS.Range("C5:C29").Offset(0, i) Else Set rng = Union(rng, WS.Range("C5:C29").Offset(0, i))
End If
Next i
rng.Value = "Volno"
Set rng = Nothing
End Select
Next WS
End Sub
Zmenil som Vám aj vzorec v bunkách D3:AH3 na tento
=PROPER(TEXT(D4;"[$-405]dddd"))
=VELKÁ2(HODNOTA.NA.TEXT(D4;"[$-405]dddd"))
aby dával české názvy dní aj v nečeských Office.

Teraz nerozumiem ja. Takže tie listy "Human", "Faer", "Neander", "Mortii" ... tam nebudú? Bude to všetko na jednom liste "Karty" v stĺpcoch AG:--> ?
Inak ten spoločný zoznam pre Overenie dát, sa dá urobiť aj cez kontingenčnú tabuľku.

Veď sa to celé deje v Podmienenom Formátovaní.
Karta Domov - Podmienené formátovanie - Spravovať pravidlá
Pravidlo funguje tak, vyhľadá v jednej tabuľke daný názov, ak nájde vyfarbí na fialovo, ak nenájde ide na ďalšie pravidlo. Tam kontroluje či sa nájde v druhom liste, ak áno vyfarbí na oranžovo, atď ...
Každé pravidlo musí mať zaškrtnuté "Zastaviť, ak je splnená podmienka", aby sa zbytočne nehľadalo ak už nájdené je. Z toho vyplýva, že ak chcete pridať ďalší list, musíte pridať aj ďalšie pravidlo so svojou farbou.

Oblasti B:C a AA:AB majú samostatné pravidlá.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje