odkaz s ohledem na měsíc Vyřešeno

[setuB]

Aha, co po mně budeš teda potřebovat?
heslo na zamknutí buňek dávám vždy zamek, heslo pro VBA můžu sehnat od původního autora.

[Reklama]

[d1amond]

vba_err.gif (10.63 KiB) Zobrazeno 385 x

Pokud by kdokoliv věděl, jak se toho zbavit? Excel 2007...
Vše by měnlo být odemčené, ale evidentně není a nevím kde to změnit.

[setuB]

A kdybych to překopal do nového excelu? Nic bych nekopíroval, jen bych to tam ručně přepsal? Pomohlo by to?

[d1amond]

Určitě. Ale nedělej to zatím celé. Jeden dva řádky, dvě buňky, dva listy. Odzkouším to a pak popojedem.

Stejně by mě zajímalo, kde tam co překáží. Chyba někde bude, ale nevím kde...

[setuB]

tak velmi očesaná verze

http://www.ulozto.cz/10303372/databaze2-xlsx

[d1amond]

// opravené počítání nevyřešených štítků

databaze2.xlsm

(26.02 KiB) Staženo 6 x

Hotovo. Je to řešené fcí, která se spustí při jakékoliv změně na listu databaze. Parametrem fce je číslo listu, v tomto případě 2. Jednoduchým přidáním řádku lze tuto fci aplikovat na přibývající listy.
Teď k řešení. Na listu 2 v buňce B1 je prozatím datum, jako testovací. V závislosti na tomto datu (odzkoušet!), resp. měsíci se plní příslušné oblasti B10:M12. Ve finále bude toto datum nahrazeno aktuálním systémovým datem.

Procedura na List1, kontroluje změny na listu1 a spouští fci na dalších listech (zatím jen na 2)

Kód: Vybrat vše

Sub Worksheet_Change(ByVal Target As Range)
UpdateSheets (2) 'list2
'UpdateSheets (3) 'list3
'UpdateSheets (4) 'list4
End Sub


Fce pro update na listech (parametrem je číslo listu) a pouští se z procedury na listu1

Kód: Vybrat vše

Option Explicit
Public Function UpdateSheets(shIndex As Byte)

Dim datum As Date
Dim mCislo As Integer
Dim mNazev As String
Dim fCell As Range
Dim x As Integer
Dim y As Integer
Dim vys As Integer

Application.ScreenUpdating = False

x = Worksheets(2).Range("B3").Value
y = Worksheets(2).Range("B4").Value
vys = x - y

datum = Worksheets(2).Range("A1") 'aktualni datum (nahradit pozdeji fcí Date)
mCislo = CInt(Month(datum)) 'cislo mesice

'v měsíci 1 smaže oblast B10:M12
If mCislo = 1 Then
Worksheets(shIndex).Range("B10:M12").Clear
End If

Select Case mCislo
    Case 1: Set fCell = Sheets(shIndex).Range("B10") 'leden
    Case 2: Set fCell = Sheets(shIndex).Range("C10") 'únor
    Case 3: Set fCell = Sheets(shIndex).Range("D10") 'březen
    Case 4: Set fCell = Sheets(shIndex).Range("E10") 'duben
    Case 5: Set fCell = Sheets(shIndex).Range("F10") 'květen
    Case 6: Set fCell = Sheets(shIndex).Range("G10") 'červen
    Case 7: Set fCell = Sheets(shIndex).Range("H10") 'červenec
    Case 8: Set fCell = Sheets(shIndex).Range("I10") 'srpen
    Case 9: Set fCell = Sheets(shIndex).Range("J10") 'září
    Case 10: Set fCell = Sheets(shIndex).Range("K10") 'říjen
    Case 11: Set fCell = Sheets(shIndex).Range("L10") 'listopad
    Case 12: Set fCell = Sheets(shIndex).Range("M10") 'prosinec
End Select

Select Case mCislo
    Case 1: mNazev = "leden"
    Case 2: mNazev = "únor"
    Case 3: mNazev = "březen"
    Case 4: mNazev = "duben"
    Case 5: mNazev = "květen"
    Case 6: mNazev = "červen"
    Case 7: mNazev = "červenec"
    Case 8: mNazev = "srpen"
    Case 9: mNazev = "září"
    Case 10: mNazev = "říjen"
    Case 11: mNazev = "listopad"
    Case 12: mNazev = "prosinec"
End Select

'vyplneni podle aktualniho mesice
With fCell
    .Value = x
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Offset(1, 0).Value = y
    .Offset(1, 0).HorizontalAlignment = xlCenter
    .Offset(1, 0).VerticalAlignment = xlCenter
    .Offset(2, 0).Value = mNazev
    .Offset(2, 0).HorizontalAlignment = xlCenter
    .Offset(2, 0).VerticalAlignment = xlCenter
End With

Application.ScreenUpdating = True

End Function


Poro použití fce na dalších listech stačí odkomentovat 'UpdateSheets (3), ...

[setuB]

ještě tam bude asi nějaká chybka, protože pokud dám Modré Štítky vyřešené, tak se mi nezmění graf

--- Doplnění předchozího příspěvku (18 Zář 2011 18:20) ---

dodělal jsem do excelu ještě další listy, prosím zda to můžeš dát i na ně

http://www.ulozto.cz/10305769/databaze2celek-xlsm
díky

[d1amond]

databaze2celek.xlsm

(31.09 KiB) Staženo 10 x

Opraveny chyby výpočtu a doplnění fcí pro zbylé listy. Datum stále ještě ponechán pro testování (upravím nakonec)

[setuB]

to už vypadá super, díky moc. Úprava datumu asi bude stačit, když tam dám funkci =DNES()?

a na mou soukromou zprávu, nezbývá než ti znovu poděkovat, takových lidí je málo

[d1amond]

Alt+F11 - editor VBA

V Modul1 toto smazat celé

Kód: Vybrat vše

datum = Worksheets(2).Range("A1") 'aktualni datum (nahradit pozdeji fcí Date)

A toto upravit - doplnit Date

Kód: Vybrat vše

mCislo = CInt(Month(Date)) 'cislo mesice

Buňka B1 s datumem je potom zbytečná.
A není zač. Případně pokud se nevyskytne nic dalšího, označ téma za vyřešené.