EXCEL: Makro pro upravu cen v ceniku Vyřešeno

[frasser]

Zdravim vsechny odborniky excelu.
Pripravuji cenik v excelu, ktery ma cca 300 listu, v priloze je vzorek me prace.
Ted v cem je problem.....
Na kazdem listu jsou ceny produktu (cervene vyznacene-pocatecni ceny), jakmile ale budu chtit udelat na cely cenik slevovou akci napr.20% tak bych musel kazdou bunku s cenou zvlast prepocitavat, coz asi bude casove dost narocne.

Tak prosim jestli si nekdo nevi rady jak nejjednodussim zpusobem upravit ceny v ceniku kdyz napr.na prvnim vytvorenem listu budu mit stav cen (100%) a budu chtit udelat slevu na 80%, tak napriklad pri prepsani ze 100 na 80 by se upravila cena u vsech produktu na vsech listech?

Je to vubec proveditelne ? Diky kazdemu kdo by mi mohl v tomto pomoci ?

(mam ted O2K3, ale neni problem dokoupit i novou verzi Office)
Roman

[Reklama]

[navstevnik]

Predpoklad je, ze struktura vsech listu je identicka - ceny jsou v bloku bunek C:J. Dalsi predpoklad je, ze pouze v radcich oznacenych Cena bez DPH jsou ciselne hodnoty, jinak by v jinych radcich doslo k "uprave hodnot" .
Potom lze pouzit nasledujici proceduru (v editoru VBA - Alt+F11 - vloz do standardniho modulu, uprav koeficient na pozadovanou hodnotu a zavolej z nabidky Nastroje>Makro>...). Ale veskere overovani delej na kopii ceniku a navic to je na tve vlastni riziko, nenesu jakoukoliv odpovednost za pripadne skody. Vysledek upravy prover.

Kód: Vybrat vše

Option Explicit

Sub HromadnaUpravaCen()
  Dim Wsht As Worksheet, Blk As Range, PClls As Range, Cll As Range
  Dim Koeficient As Single
  ' zde vloz koeficient upravy (desetinny oddelovac je ve VBA: . (tecka)
  Koeficient = 1
  '***************************
  For Each Wsht In ActiveWorkbook.Worksheets
    Set Blk = Nothing
    Set Blk = Intersect(Wsht.UsedRange, Wsht.Range("c:j")) ' oblast cen
    Set PClls = Nothing
    Set PClls = Blk.SpecialCells(xlCellTypeConstants, xlNumbers) ' bunky s cenami
    For Each Cll In PClls.Cells
      Cll.Value = Cll.Value * Koeficient ' nasobit koeficientem
    Next Cll
  Next Wsht
  ' odstranit objektove promenne
  Set Cll = Nothing
  Set PClls = Nothing
  Set Blk = Nothing
  Set Wsht = Nothing
End Sub

A zvladne to i Excel 2000-2003

[frasser]

No to neni mozne ) Ten pan navstevnik je proste " EXCELentni " .
Funguje to uzasne, jeste to otestuji v kopii kompletniho sesitu ceniku a provedu kontrolu udaju, ale uz ted to vypada moc dobre a tech par radku, ktere pan navstevnik napsal mi urcite usetri spoustu casu a ja mu timto skladam velkou poklonu.
Diky, diky, diky
Roman

[navstevnik]

Nize je procedura doplnena o osetreni stavu, kdy na listu nebude nalezena bunka obsahujici v zadane oblasti ciselnou hodnotu (Cenu):

Kód: Vybrat vše

Option Explicit

Sub HromadnaUpravaCen()
  Dim Wsht As Worksheet, Blk As Range, PClls As Range, Cll As Range
  Dim Koeficient As Single
  ' zde vloz koeficient upravy (desetinny oddelovac je ve VBA: . (tecka)
  Koeficient = 1
  '***************************
  For Each Wsht In ActiveWorkbook.Worksheets
    Set Blk = Nothing
    Set Blk = Intersect(Wsht.UsedRange, Wsht.Range("c:j"))  ' oblast cen
    Set PClls = Nothing
    On Error Resume Next
    Set PClls = Blk.SpecialCells(xlCellTypeConstants, xlNumbers)  ' bunky s cenami
    On Error GoTo 0
    If Not PClls Is Nothing Then
      For Each Cll In PClls.Cells
        Cll.Value = Cll.Value * Koeficient  ' nasobit koeficientem
      Next Cll
    End If
  Next Wsht
  ' odstranit objektove promenne
  Set Cll = Nothing
  Set PClls = Nothing
  Set Blk = Nothing
  Set Wsht = Nothing
End Sub

[frasser]

Na to jsem ani nepomyslel, to je dobre osetreni, protoze mam na nekterych listech pouze doplnkove informace a tam to hlasilo chybu.

Vidim, ze jsem se dostal k tomu spravnemu odbornikovi :)

Mohl bych tedy jeste poprosit o jednu vychytavku, pokud je proveditelna? Sly by ty vysledne hodnoty zaokrouhlovat na cele desetniky? Vim, ze by se to dalo osetrit zmenou poctu desetinnych mist na jedno (to excel dopocita), ale to uz potom nevypada jako cena, ale obycejne cislo. Tedy kdyz makro spocita napr hodnotu 58,63 tak aby se automaticky zaokrouhloval na 58,60 nebo v pripade 62,77 na hodnotu 62,80 ?

Diky za Vas cas pane navstevniku.

[navstevnik]

Doplneno o zaokrouhlovani (bankovni) a format 0,00:

Kód: Vybrat vše

Option Explicit

Sub HromadnaUpravaCen()
  Dim Wsht As Worksheet, Blk As Range, PClls As Range, Cll As Range
  Dim Koeficient As Single
  ' zde vloz koeficient upravy (desetinny oddelovac je ve VBA: . (tecka)
  Koeficient = 1
  '***************************
  For Each Wsht In ActiveWorkbook.Worksheets
    Set Blk = Nothing
    Set Blk = Intersect(Wsht.UsedRange, Wsht.Range("c:j"))  ' oblast cen
    Set PClls = Nothing
    On Error Resume Next
    Set PClls = Blk.SpecialCells(xlCellTypeConstants, xlNumbers)  ' bunky s cenami
    On Error GoTo 0
    If Not PClls Is Nothing Then
      For Each Cll In PClls.Cells
      ' nasobit koeficientem, zaokrouhlit na 1 des misto (bankovni zaokuhl.), format 0,00
        Cll.Value = CSng(Format(Round(Cll.Value * Koeficient, 1), "0.00"))
      Next Cll
    End If
  Next Wsht
  ' odstranit objektove promenne
  Set Cll = Nothing
  Set PClls = Nothing
  Set Blk = Nothing
  Set Wsht = Nothing
End Sub

Ma to ovsem jeden dusledek, nelze presne prepocitat na puvodni ceny (* 0,80 a zpet * 1,25).

[frasser]

To uz mi nevadi, protoze budu pocitat pouze s cenou aktualni (navic si muzu delat zalohu predchozich cen a tim osetrim tuto odchylku ve vypoctech). Tohle chodi presne podle mych predstav, parada.

Tak dekuji za pomoc.
Roman