Changing a positive numeric cell input into a negative numeric value in the same cell based on criteria in another cell

user_13743896 0
Viewed 99

I want to change a positive value cell input in a range to a negative value by reference to a criteria in another cell range. So for instance cell range A1:A10 contains either a value of "B" or "S". Cell range B1:B10 is where the numeric values are entered. These values when entered are either made positive or negative values depending on the data already entered in corresponding cells A1:A10. So entering any value whether positive or negative in say B1 as either 1234 or -1234 where A1 has a value "B" will result in B1 displaying -1234. Conversely where any value whether positive or negative is input in Cells B1:B10 and the value of the corresponding row in column A is "S" the value in column B will always be positive irrespective of whether the original input was negative or positive.

If there is no value in a particular cell in the range A1:A10 corresponding to the same row in column B then a message should be displayed to the user saying "Please enter a value in the corresponding row in column A.

I am a complete novice to VBA coding and so far looking at other posts have cobbled together following code, but I do not know how to complete it to work successfully.

Any help would be very much appreciated.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim A1 As Range
    Set A1 = Range("A1:A10")
    Dim A2 As Range
    Set A2 = Range("B1:B10")
    If Intersect(Target, A2) Is Nothing Then Exit Sub
    If IsText(Target, A1) Then
        If A1 = "S" Then
        Application.EnableEvents = False
            B1 = -B1
        Application.EnableEvents = True
    End If
End Sub
negative-number vba excel
2 Answers

This should be what you need:

The For loop allows you to change more than one column B value at a time.
If the column A value is neither of "B" or "S", no action is taken.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim B As Range, Intersection As Range, cell As Range
    Dim v As String
    Set B = Range("B1:B10")
    Set Intersection = Intersect(Target, B)

    If Intersection Is Nothing Then Exit Sub

    Application.EnableEvents = False
        For Each cell In Intersection
            v = cell.Offset(0, -1).Value
            If v = "B" Then
                cell.Value = -Abs(cell.Value)
            ElseIf v = "S" Then
                cell.Value = Abs(cell.Value)
            End If
        Next cell
    Application.EnableEvents = True
End Sub
user_24746560

An In-Place Worksheet Change

  • Copy the whole code into a sheet module (e.g. Sheet1).
  • The code does everything automatically, nothing to run here.
  • The function 'gets' the column range starting from the cell in FirstRow to the last non-empty cell.
  • The code automatically modifies the value that is entered in column B depending on the value in column A.

The Code

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Const Proc As String = "Worksheet_Change"
    On Error GoTo cleanError

    Const FirstRow As Long = 1
    Dim Criteria As Variant: Criteria = Array("S", "B", "")
    Dim Cols As Variant: Cols = Array(1, 2) ' or Array("A", "B")

    Dim rngS As Range: Set rngS = getColumnRange(Me, Cols(1), FirstRow)
    If rngS Is Nothing Then Exit Sub
    Dim rngT As Range: Set rngT = Intersect(Target, rngS)
    If rngT Is Nothing Then Exit Sub
    Dim ColOffset As Long
    ColOffset = Columns(Cols(0)).Column - Columns(Cols(1)).Column

    Application.EnableEvents = False
    Dim cel As Range
    For Each cel In rngT.Cells
        Select Case cel.offset(, ColOffset).Value
            Case Criteria(0): cel.Value = Abs(cel.Value)
            Case Criteria(1): cel.Value = -Abs(cel.Value)
            Case Criteria(2): cel.Value = "Please enter a value into cell '" _
              & cel.offset(, ColOffset).Address(0, 0) & "'."
            Case Else ' Maybe the same as the previous!?
        End Select
    Next

CleanExit:
    Application.EnableEvents = True

Exit Sub

cleanError:
    MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
       & "Run-time error '" & Err.Number & "':" & vbCr _
       & Err.Description, vbCritical, Proc & " Error"
    On Error GoTo 0
    GoTo CleanExit

End Sub

Function getColumnRange(Sheet As Worksheet, _
                        ByVal AnyColumn As Variant, _
                        Optional ByVal FirstRow As Long = 1) _
         As Range
    Dim rng As Range
    Set rng = Sheet.Columns(AnyColumn).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Function
    If rng.Row < FirstRow Then Exit Function
    Set getColumnRange = Sheet.Range(Sheet.Cells(FirstRow, AnyColumn), rng)
End Function
user_98140690
Related