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

Příspěvky uživatele

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

Private Sub Workbook_Open()
Dim R As Long, D(), V() As String, SA As String, SB As String

With ThisWorkbook.Worksheets("List1")
R = .Cells(Rows.Count, "B").End(xlUp).Row
D = .Cells(1, 1).Resize(R, 3).Value
End With
ReDim V(UBound(D, 1) - 1)

For R = 1 To R
If D(R, 3) > 0 Then V(R - 1) = D(R, 2) & D(((R - 1) \ 3) * 3 + 1, 1) & " - " & 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

SA = Replace(Join(Filter(V, "Směna A", True), vbCrLf), "Směna A", "")
If SA <> "" Then SA = "Směna A" & vbCrLf & vbCrLf & SA

SB = Replace(Join(Filter(V, "Směna B", True), vbCrLf), "Směna B", "")
If SB <> "" Then SA = IIf(SA = "", "", SA & vbCrLf & vbCrLf) & "Směna B" & vbCrLf & vbCrLf & SB

If SA <> "" Then MsgBox SA, vbExclamation, "Přehled plných směn."
End Sub

Pozerám u kolegu vyššie - dobrý nápad s tými Tabulátormi. Úprava s nimi:
Private Sub Workbook_Open()
Dim R As Long, D(), V() As String, SA As String, SB As String

With ThisWorkbook.Worksheets("List1")
R = .Cells(Rows.Count, "B").End(xlUp).Row
D = .Cells(1, 1).Resize(R, 3).Value
End With
ReDim V(UBound(D, 1) - 1)

For R = 1 To R
If D(R, 3) > 0 Then V(R - 1) = vbTab & D(R, 2) & D(((R - 1) \ 3) * 3 + 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

SA = Replace(Join(Filter(V, "Směna A", True), vbCrLf), "Směna A", "")
If SA <> "" Then SA = "Směna A :" & vbCrLf & SA

SB = Replace(Join(Filter(V, "Směna B", True), vbCrLf), "Směna B", "")
If SB <> "" Then SA = IIf(SA = "", "", SA & vbCrLf & vbCrLf) & "Směna B :" & vbCrLf & SB

If SA <> "" Then MsgBox SA, vbExclamation, "Přehled plných směn."
End Sub

Som len na mobile, skúste dať prílohu s ukážkou vzorcov. Bude potrebné použiť VLOOKUP v prevodnej tabuľke, a vzorce nálezite upraviť.

Sub Group_Click()
MsgBox Worksheets("Hárok1").Shapes(Application.Caller).ParentGroup.Name
End Sub
Základom je:
-Nastavené rovnaké makro pre všetky prvky všetkých skupín.
-Pozor! Nefunguje, ak sa vytvárajú ďalšie skupiny kopírovaním. Musí sa každá skupina sama o sebe Zoskupiť.
-GroupNmae vráti ENG názov skupiny, nie ten, čo Vám predvolene ukazuje CZ/SK mutácia Excelu v "Tabla Výberu". Tam si ich premenujte na nejaké zmysluplné, a potom makro vráti už to premenované.

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse