Příspěvky uživatele
< návrat zpět
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á.
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.
Uživatelské menu
\nFormulář 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