Příspěvky uživatele

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

No len ak bude v SK/EN Exceli vybrané z výberového zoznamu slovo "Leden" tak to nepôjde. A treba ošetriť dni od >28.

Teoreticky nepotrebujete ani tú pomocnú tabuľku mesiacov a ani C2.

Takto by to mohlo vyzerať s ukladaním do Definovaného názvu. Zároveň som ponechal ešte aj funkcionalitu Static.

Samozrejme, že zatvorenie súboru zmaže všetky premenné. O tom nebola reč. To by sa muselo zapisovať napr.:
-do buniek (skrytých v skrytom liste) a súbor uložiť (cestuje v súbore)
-do Definovaných názvov a súbor uložiť (cestuje v súbore)
-do Registru Windows (iba lokálny PC)
-do TXT súboru niekam na disk (iba lokálny PC)

Skúste, či toľko vyhľadávaní bude rýchlostne v pohode.

Pr.

Použitie deklarácie Static. Musí byť vo funkcii alebo procedúre. Static ostanú zapamätané aj po skončení makra. Nuluje ich chyba, Stop makra, alebo ZOBRAZENIE VBA EDITORA ! Nesmie byť zobrazený VBA editor!
Funkciu fncCisloNastaveni som urobil tak, že ak sa jej zadá iba 1 číslo, je to pre ňu signál, že má vrátiť danú zapamätanú hodnotu v poradí.
No ak sa jej zadá pole parametrov (daných je podľa požiadavky 13), tak tieto hodnoty zapisuje do svojich uchovávaných Static hodnôt.
Toto vráti 2. uloženú hodnotu spomedzi 13.-ich:
MsgBox fncCisloNastaveni(2)
a toto zapamätá všetkých 13 hodnôt
fncCisloNastaveni 0, 1, 20, 0, 0, 6, 4, 0, 0, 0, 1, 0, 2
(vo forme sú tam Labely)
Skúste, či to bude vyhovovať.

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje