Automatically multiplying cells

Question

Hi,

I want to be able to enter a value into a cell (within a specified range) and have it automatically multiply by a set value with the result so making. But I want to be able to automatically multiply different cells by different numbers

Is this possible?

I used this code to do this and it worked

Private Sub Worksheet_Change(ByVal Target As Range)

Const WS_RANGE As String = "D7, F7, B10:B15"     '<== change to suit

Const SET_VALUE As Double = .2367            '<== change to suit

    On Error GoTo ws_exit

    Application.EnableEvents = False

    If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then

        With Target

            If IsNumeric(.Value) Then .Value = .Value * SET_VALUE

        End With

    End If

ws_exit:

    Application.EnableEvents = True

End Sub

The problem is I also want to multiply range "D18, F18, B21:B26" by .4495 and range "D29, F29, B32:B37" by .3879

Thanks

 M

Answer 1

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim Where, What

  Dim i As Integer

  Dim Part As Range, This As Range

  'Events off, otherwise we call ourself

  Application.EnableEvents = False

  'Setup cells and values

  Where = Array("D7, F7, B10:B15", "D18, F18, B21:B26", "D29, F29, B32:B37")

  What = Array(0.2367, 0.4495, 0.3879)

  For i = 0 To UBound(Where)

    'Get the part

    Set Part = Intersect(Target, Me.Range(Where(i)))

    'Something changed in there?

    If Not Part Is Nothing Then

      'In each of this cells

      For Each This In Part

        'Multiply numerical values

        If IsNumeric(This) Then This = This * What(i)

      Next

    End If

  Next

  Application.EnableEvents = True

End Sub