Help with modifying VBA Code (very powerful code)

0

Hi

I have attached code below, I need help with modifying the same,

This code checks whether Range has formulas in it, if range does not have formulas, it exists but if it does have formulas, it does

Adds Rounup function with "" which is invalid (I want to remove that step)

secondly if Range/cells has Round with "" at end, it will change it to Round "0" which is correct and valid roundup function

and lastly it removes round up function completed keeping the formula as it was before wrapping them into round up

As mentioned above, I want to remove invalid wrapping of roundup function with "" and keep test only to Roundup to 0 or remove round up if roundup already exists in range or cells

Also How can I modify the function to round up by 1000 or 1000000 (by input box popup) and change it back to normal formula as it was...?

Thanks

Sub RoundupCells()
'
'PURPOSE: Add an ROUNDUP() Function around all the selected cells' formulas. _
          Also handles if ROUNDUP is already wrapped around formula.
Dim Rng As Range
Dim cell As Range
Dim AlreadyROUNDUP As Boolean
Dim RemoveROUNDUP As Boolean
Dim TestEnd1 As String
Dim TestEnd2 As String
Dim TestStart As String
Dim MyFormula As String
Dim x As String

'Determine if a single cell or range is selected
  If Selection.Cells.Count = 1 Then
    Set Rng = Selection
    If Not Rng.HasFormula Then GoTo NoFormulas
  Else
    'Get Range of Cells that Only Contain Formulas
      On Error GoTo NoFormulas
        Set Rng = Selection.SpecialCells(xlCellTypeFormulas)
      On Error GoTo 0
  End If
  
'Get formula from First cell in Selected Range
  MyFormula = Rng(1, 1).Formula

'Create Test Strings To Determine if ROUNDUP formula has already been added
  TestEnd1 = Chr(34) & Chr(34) & ")"
  TestEnd2 = ",0)"
  TestStart = Left(MyFormula, 9)

'Determine How we want to modify formula
  If Right(MyFormula, 3) = TestEnd1 And TestStart = "=ROUNDUP(" Then
    Beg_String = ""
    End_String = "0)" '=ROUNDUP([formula],0)
    AlreadyROUNDUP = True
  ElseIf Right(MyFormula, 3) = ",0)" And TestStart = "=ROUNDUP(" Then
    RemoveROUNDUP = True
  Else
    Beg_String = "=ROUNDUP("
    End_String = "," & Chr(34) & Chr(34) & ")" '=ROUNDUP([formula],"")
    AlreadyROUNDUP = False
  End If

'Loop Through Each Cell in Range and modify formula
  For Each cell In Rng.Cells
    x = cell.Formula

    If RemoveROUNDUP = True Then
      cell = "=" & Mid(x, 10, Len(x) - 12) 'Removes Rounupformula if cell has rounup function
    ElseIf AlreadyROUNDUP = False Then
      cell = Beg_String & Right(x, Len(x) - 1) & End_String 'Adds =ROUNDUP([formula],"")
    Else
      cell = Left(x, Len(x) - 3) & End_String 'Adds =ROUNDUP([formula],0)
    End If
    
  Next cell

Exit Sub

'Error Handler
NoFormulas:
  MsgBox "There were no formulas found in your selection!"
  
End Sub

Answer
Discuss

Answers

0
Selected Answer

Try this:

Sub RoundupCells()
'
'PURPOSE: Add an ROUNDUP() Function around all the selected cells' formulas. _
          Also handles if ROUNDUP is already wrapped around formula.
Dim Rng As Range
Dim cell As Range
Dim AlreadyROUNDUP As Boolean
Dim RemoveROUNDUP As Boolean
Dim TestStart As String
Dim MyFormula As String
Dim x As String

'Determine if a single cell or range is selected
  If Selection.Cells.Count = 1 Then
    Set Rng = Selection
    If Not Rng.HasFormula Then GoTo NoFormulas
  Else
    'Get Range of Cells that Only Contain Formulas
      On Error GoTo NoFormulas
        Set Rng = Selection.SpecialCells(xlCellTypeFormulas)
      On Error GoTo 0
  End If

'Get user input for how much to round up
round_up_digits = InputBox("By how much do you want to round?")

'Get formula from First cell in Selected Range
  MyFormula = Rng(1, 1).Formula

'Create Test Strings To Determine if ROUNDUP formula has already been added
  TestStart = Left(MyFormula, 9)

'Determine How we want to modify formula
  If TestStart = "=ROUNDUP(" Then
    Beg_String = ""
    End_String = "0)" '=ROUNDUP([formula],0)
    RemoveROUNDUP = True
  Else
    Beg_String = "=ROUNDUP("
    End_String = "," & round_up_digits & ")" '=ROUNDUP([formula],"")
    AlreadyROUNDUP = False
  End If

'Loop Through Each Cell in Range and modify formula
  For Each cell In Rng.Cells
    x = cell.Formula

    If RemoveROUNDUP = True Then
      cell = "=" & Mid(x, 10, InStrRev(x, ",") - 10) 'Removes Rounupformula if cell has roundup function
    ElseIf AlreadyROUNDUP = False Then
      cell = Beg_String & Right(x, Len(x) - 1) & End_String 'Adds =ROUNDUP([formula],"")
    Else
      cell = Left(x, Len(x) - 3) & End_String 'Adds =ROUNDUP([formula],0)
    End If

  Next cell

Exit Sub

'Error Handler
NoFormulas:
  MsgBox "There were no formulas found in your selection!"

End Sub

I wasn't 100% certian how you wanted it to function but just a few minor changes needed to be made to allow user input for the rounding and to remove the "" part that was being input.

Discuss

Discussion

Thank you So much for helping me out ! we are half way through :)

Actually, I wanted to make two codes using original code:

1 - Toggles rooundUp function to formulas only (add roundup and removes round up if already exists) - no input box required.. just remove "" option which is third click toggle (only two conversions I want , roundup to normal formula and vice versa)

2 - using same code, adding input box option which divides range/cells with desired number (eg- I always convert whole numbers into thousands and millions for reporting to management), while another input box for asking decimal up to which rounding is required (which you did already)

Thank you once again and awaiting reply....

Prash
ExAccounting (rep: 2) Jul 21, '16 at 2:17 am
Update your original question with this information! Future users will not be able to follow this unless your question contains all of the information.
don (rep: 1297) Jul 21, '16 at 12:00 pm
You never updated your original question, unless I am missing something...
don (rep: 1297) Aug 3, '16 at 2:41 pm
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login