MS Excel

Dobrý den
Prosím o radu. V souboru mám nasimulováno při otevření sešitu, aby se zobrazovala zpráva, že ta a ta směna má plné obsazení šichet. Jenže to mám tak, že se zobrazí zpráva za každý měsíc a každou šichtu zvlášť. Bylo by možné, aby se pro každou šichtu (Směna A, Směna B) zobrazila jenom jedna zpráva, ve které by byly vypsány ty měsíce s plnými šichtami?
Díky

Zaslat odpověď >

Dita(6.1.2021 12:51)#049368

Tak jsem to trochu pořešil. Nezdá se mi to zrovna košér, ale funguje to. Když nebude mít "Směna A" žádnou plnou šichtu (C1, C4, C7, C10 = 0) tak se MsgBox nespustí. To je OK. Jakmile se změní jedna z těchto hodnot, tak se MSgBox spustí a vypíše VŠECHNY měsíce a u každého kolik směn je plných, popř., když nemá žádnou, že je to v pořádku. Představoval bych si ale, když už se MsgBox spustí, aby vypsal jenom měsíce ve kterém je nějaká plná šichta. S tím si nevím rady.
Děkuji za radu.

Příloha: rar

49368_pokus_oznameni-leden-duben.rar (15kB, staženo 14x)

citovat

Milan-158(6.1.2021 13:41)#049369

Zde inspirace jak to dělat "košér". Snad si to upravíš dle sebe:
Dim strA As String, strB As String
Dim i As Integer, iMax As Integer
Dim ws As Worksheet

ThisWorkbook.Activate
Set ws = Worksheets("List1")

'poslední řádek:
iMax = Application.Max(ws.Range("A65000").End(xlUp).Row, ws.Range("B65000").End(xlUp).Row, ws.Range("C65000").End(xlUp).Row)

'vyskládej text za směnu A
strA = "Směna A:" & vbCrLf
For i = 1 To iMax Step 3
strA = strA & vbTab & ws.Cells(i, "A") & vbTab & ws.Cells(i, "D") & vbCrLf
Next i

'vyskládej text za směnu B
strB = "Směna B:" & vbCrLf
For i = 2 To iMax Step 3
strB = strB & vbTab & ws.Cells(i - 1, "A") & vbTab & ws.Cells(i, "D") & vbCrLf
Next i
MsgBox Prompt:=strA & vbCrLf & strB, Buttons:=vbOK, Title:="Přehled plných směn"
citovat

Dita(6.1.2021 14:52)#049370

@Milan-158 to je jiná. Ale jsou 4 směny a to bude box docela dlouhej (vysokej). Proto jsem myslel, že by se vypsaly pouze měsíce, kdy jsou plné šichty. To by se hodně zkrátil. Ve skutečnosti jich moc nebude. Mělo by to být upozornění pro vedoucí směn, aby si ty plné šichty rozplánovaly. V ideálním stavu by MsgBox neměl vůbec zobrazit, což se ale nestává.
I tak díky.citovat

Milan-158(6.1.2021 16:08)#049371

No tak konečně známe pravý účel makra, který byl na počátku jen mlhavě naznačený.
Tomu by pak odpovídalo i řešení.

No nic ...citovat

Dita(6.1.2021 17:19)#049372

Nebyl v tom žádný úmysl

citovat

elninoslov(6.1.2021 18:03)#049373

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 Subcitovat

Dita(6.1.2021 18:34)#049375

@elninoslov tak takto jsem si to představoval

. Teď jestli to napasuju do mého sešitu

. A už vůbec nechápu, jak to někdo vymyslí

Díkycitovat

Dita(9.1.2021 21:15)#049419

@elninoslov, můžu požádat o úpravu pro 4 směny? Já se v tom plácám a furt mi to nefunguje, tak jak by mělo. Je to vlastně pokus-omyl

Děkuji předem

Příloha: rar

49419_pokus_oznameni_2.rar (19kB, staženo 13x)

citovat

elninoslov(9.1.2021 22:51)#049420

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

Příloha: zip