Cenník - precenenie

Mame vytvorený cenník napr. hardweru (obr. 1). Potrebujeme ceny zmeniť, vynásobením jednotlivých cien nejakým koficientom, napr. 1,3. Ak však máme niekoľko tisíc položiek, nebudeme úlohu riešiť vzorcom a potiahnutím za úchytku bunky, ale zostavíme program (makro) vo VBA (Visual Basic for Aplications). Ako je zobrazené na obrázku 2, v treťom stĺpci chceme mať zmenené ceny. CurrentRegion je oblasť v ktorej je kurzor a je ohraničená prázdnym riadkom a prázdnym stĺpcom.

Sub Precen()
Dim n As Integer, k As Integer, m As Single
Dim pocr As Integer, pocs As Integer, obl As Object
Worksheets(1).Activate
m = 1.3 ' tu môžete vymeniť koefiient (miesto 1.3 napr. 1.8 alebo ľubovoľný)
Set obl = ActiveCell.CurrentRegion
pocr = obl.Rows.Count
pocs = obl.Columns.Count
' Debug.Print obl.Rows.Count & " rows."
' Debug.Print obl.Columns.Count & " columns."
n = pocs + 1
Cells(1, 1).Select
Selection.Copy
Cells(1, n).Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone
Application.CutCopyMode = False
Cells(1, n).Select
ActiveCell.FormulaR1C1 = "Precenenie"
For k = 2 To pocr ' od riadku č. 2 po pocsedný
Cells(k, n) = Cells(k, pocs) * m
Cells(k, n).Select
Selection.NumberFormat = "#,##0.00 $"
With Selection.Interior
        .ColorIndex = 50
        .Pattern = xlSolid
End With
    Selection.Font.ColorIndex = 2
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
End With
Next k
Columns(n).Select
With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
End With
With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 2
End With
Cells(1, n).Select
ActiveCell.FormulaR1C1 = "Precenenie"
With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = 1
End With
With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 53
End With
Columns(n).EntireColumn.AutoFit
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
End With
End Sub