Can multiple Range but not individual cells.

Hi everyone,

Can someone please help me? I'm currently trying to get VBA to select certain cells and then multiple them out.

Its currently working with ranges but not when I'm trying to do multiple single cells.

I'm not sure what I'm doing wrong.

Im currently getting a #value when im trying to multiple it out.

Code:

---

Sub pricepercincrease()


Dim priceincrease, percentage As Variant
Dim r1, r2, wrange As Range
Dim selecttab As String
Dim promptmsgbox As Integer




On Error GoTo errorend


percentage = InputBox("Please enter the percentage you wish to increase by?", "Price Increase")
priceincrease = (percentage / 100) + 1


selecttab = InputBox("Please select a worksheet to increase?" & vbNewLine & vbNewLine & "1. Discounts C&P" & vbNewLine & "2. Finishing" & vbNewLine & "3. Air Valves & Circulars" & vbNewLine & "4. Ceiling Diffusers" & vbNewLine & "5. Ceiling Swirls" & vbNewLine & "6. Displacement Vents" & vbNewLine & "7. Fireblocks & PSG" & vbNewLine & "8. Floor Grilles" & vbNewLine & "9. Floor Diffusers & Swirls" & vbNewLine & "10. High Induction Slots" & vbNewLine & "11. Jet & Cylinder" & vbNewLine & "12. Laminar Flow Panels" & vbNewLine & "13. Linear Bar Grilles" & vbNewLine & "14. Linear Fixed Ceiling Diffuser" & vbNewLine & "15. Linear Slot Diffusers" & vbNewLine & "16. Louvres" & vbNewLine & "17. OBD" & vbNewLine & "18. Plenums" & vbNewLine & "19. Security Grilles" & vbNewLine & "20. Wall Grilles" & vbNewLine & "21. Contract Diffuser Range" & vbNewLine & "22. Fixings" & vbNewLine & "23. TEST", "Tab Increase")


Select Case selecttab


'1. Discounts C&P
Case 1
promptmsgbox = MsgBox("This is will update Discounts C&P by " & percentage & "%", vbCritical + vbYesNo + vbDefaultButton2, "Continue?")


If promptmsgbox = vbYes Then


'********************************************************************
'WORKS FOR RANGE BUT NOT SINGLE CELLS
Set wrange = ThisWorkbook.Worksheets("Test").Range("H21, H23, H25")

'TESTING TO SELECT A RANGE USING UNISON INSTEAD
'Set r1 = ThisWorkbook.Worksheets("TEST").Range("H21:H25")
'Set r2 = ThisWorkbook.Worksheets("TEST").Range("G21:G28")
'Set wrange = Union(r1, r2)


ThisWorkbook.Worksheets("TEST").Select




'********************************************************************


'MsgBox (wrange)
MsgBox (percentage)
MsgBox (priceincrease)


Else
Exit Sub
End If




'multiples out the percentage against the range
wrange = Evaluate(wrange.Address & "*" & priceincrease)


'roundsup all ranges to two decimals places
For Each cell In wrange
        cell.Value = WorksheetFunction.Round(cell.Value, 2)
    Next cell


'selects format display to two decimal places
Selection.NumberFormat = "0.00"






wrange.Select


Exit Sub


errorend:


MsgBox ("An error has occured when trying to increase " & selectab)


End Sub

---

I think it might have something to do with the final calculation. Its looking to do the wrange * percentage which = sum(range*percentage) (D21:M30*Perc)
If I put multiple values its just adding them to a long list ie = sum d21 m30 e50 * per

Code:

---

Sub pricepercincrease()
Dim priceincrease, percentage As Variant
Dim r1, r2, wrange As Range
Dim selecttab As String
Dim promptmsgbox As Integer

On Error GoTo errorend
percentage = InputBox("Please enter the percentage you wish to increase by?", "Price Increase")
priceincrease = (percentage / 100) + 1
selecttab = InputBox("Please select a worksheet to increase?" & vbNewLine & vbNewLine & "1. Discounts C&P" & vbNewLine & "2. Finishing" & vbNewLine & "3. Air Valves & Circulars" & vbNewLine & "4. Ceiling Diffusers" & vbNewLine & "5. Ceiling Swirls" & vbNewLine & "6. Displacement Vents" & vbNewLine & "7. Fireblocks & PSG" & vbNewLine & "8. Floor Grilles" & vbNewLine & "9. Floor Diffusers & Swirls" & vbNewLine & "10. High Induction Slots" & vbNewLine & "11. Jet & Cylinder" & vbNewLine & "12. Laminar Flow Panels" & vbNewLine & "13. Linear Bar Grilles" & vbNewLine & "14. Linear Fixed Ceiling Diffuser" & vbNewLine & "15. Linear Slot Diffusers" & vbNewLine & "16. Louvres" & vbNewLine & "17. OBD" & vbNewLine & "18. Plenums" & vbNewLine & "19. Security Grilles" & vbNewLine & "20. Wall Grilles" & vbNewLine & "21. Contract Diffuser Range" & vbNewLine & "22. Fixings" & vbNewLine & "23. TEST", "Tab Increase")
Select Case selecttab
    '1. Discounts C&P
  Case 1
    promptmsgbox = MsgBox("This is will update Discounts C&P by " & percentage & "%", vbCritical + vbYesNo + vbDefaultButton2, "Continue?")
    If promptmsgbox = vbYes Then
      Set wrange = ThisWorkbook.Worksheets("Test").Range("H21, H23, H25")
      MsgBox (percentage)
      MsgBox (priceincrease)
      For Each cell In wrange
        cell.Value = WorksheetFunction.Round(cell.Value * priceincrease, 2)
        cell.NumberFormat = "0.00"
      Next cell
      wrange.Select
    End If
End Select
Exit Sub
errorend:
MsgBox ("An error has occured when trying to increase " & selectab)

End Sub

---

Omg thank you. I knew I wasnt far off. I had round before hand and put it into a loop but it wasnt working correctly so gave up on the idea. Top bloke thank you.

Quote:

---

Originally Posted by p45cal

Code:

---

Sub pricepercincrease()
Dim priceincrease, percentage As Variant
Dim r1, r2, wrange As Range
Dim selecttab As String
Dim promptmsgbox As Integer

On Error GoTo errorend
percentage = InputBox("Please enter the percentage you wish to increase by?", "Price Increase")
priceincrease = (percentage / 100) + 1
selecttab = InputBox("Please select a worksheet to increase?" & vbNewLine & vbNewLine & "1. Discounts C&P" & vbNewLine & "2. Finishing" & vbNewLine & "3. Air Valves & Circulars" & vbNewLine & "4. Ceiling Diffusers" & vbNewLine & "5. Ceiling Swirls" & vbNewLine & "6. Displacement Vents" & vbNewLine & "7. Fireblocks & PSG" & vbNewLine & "8. Floor Grilles" & vbNewLine & "9. Floor Diffusers & Swirls" & vbNewLine & "10. High Induction Slots" & vbNewLine & "11. Jet & Cylinder" & vbNewLine & "12. Laminar Flow Panels" & vbNewLine & "13. Linear Bar Grilles" & vbNewLine & "14. Linear Fixed Ceiling Diffuser" & vbNewLine & "15. Linear Slot Diffusers" & vbNewLine & "16. Louvres" & vbNewLine & "17. OBD" & vbNewLine & "18. Plenums" & vbNewLine & "19. Security Grilles" & vbNewLine & "20. Wall Grilles" & vbNewLine & "21. Contract Diffuser Range" & vbNewLine & "22. Fixings" & vbNewLine & "23. TEST", "Tab Increase")
Select Case selecttab
    '1. Discounts C&P
  Case 1
    promptmsgbox = MsgBox("This is will update Discounts C&P by " & percentage & "%", vbCritical + vbYesNo + vbDefaultButton2, "Continue?")
    If promptmsgbox = vbYes Then
      Set wrange = ThisWorkbook.Worksheets("Test").Range("H21, H23, H25")
      MsgBox (percentage)
      MsgBox (priceincrease)
      For Each cell In wrange
        cell.Value = WorksheetFunction.Round(cell.Value * priceincrease, 2)
        cell.NumberFormat = "0.00"
      Next cell
      wrange.Select
    End If
End Select
Exit Sub
errorend:
MsgBox ("An error has occured when trying to increase " & selectab)

End Sub

---

---

How do I change it to solved please?

go to thread tools at the top