Home > OS >  Automatically update cells with dependent dropdown values
Automatically update cells with dependent dropdown values

Time:10-02

I have a sheet where there are two columns (Column C and column E). Column E has cells with dropdown menus that are dependent on the value of the cells in the same row, Column C.

I am trying to get the value in Column E to automatically change to the first option of the new corresponding dropdown menu when the value in Column C changes. As it stands, when the value in Column C changes, the value from before in the respective Column E cell remains, and I have to manually click and select from the new list.

Here is what I have to start:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng(1) As Range, rng1 As Range
Set rng(0) = Range("C71:C91")
Set rng(1) = Range("E71:E91")
Application.EnableEvents = False
If Not Intersect(Target, rng(0)) Is Nothing Then
   For Each rng1 In rng(1)
     i = i   1
     rng1 = Range("" & rng(0).Value2)(i, 1)
   Next
End If
Application.EnableEvents = True
End Sub

CodePudding user response:

Haven't fully tested the code, but can see a basic bug. Line:

For Each rng1 In rng(1)

Should read:

For Each rng1 In rng(1).Cells

CodePudding user response:

Recalculate the sheet with Application.CalculateFull after your if statement.

CodePudding user response:

A Worksheet Change with Data Validation (Drop-Downs)

  • It is assumed that the drop-downs in E71:E91 'get' the values from C71:C91 and that when you change (manually or via VBA) a value in C71:C91, the value in the same row of E71:E91 will be overwritten with this value.
  • Out-comment or delete the Debug.Print lines when done testing.
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Debug.Print "Worksheet Change Sequence at " & Now
    Debug.Print "1. '" & Target.Address(0, 0) & "' has changed."

    Dim srg As Range: Set srg = Range("C71:C91")
    Dim drg As Range: Set drg = Range("E71:E91")
    Dim irg As Range: Set irg = Intersect(srg, Target)
    Debug.Print "2. Range references created."
    
    If irg Is Nothing Then
        Debug.Print "3. No intersecting range. Exiting."
        Exit Sub
    Else
        Debug.Print "3. Intersecting range at '" & irg.Address(0, 0) & "'."
    End If
    
    On Error GoTo ClearError
    Application.EnableEvents = False
    Debug.Print "4. Error handler activated. Events disabled."
     
    ' Write to intersecting rows only.
    Dim dCol As Long: dCol = drg.Column
    Dim iCell As Range
    For Each iCell In irg.Cells
        iCell.EntireRow.Columns(dCol).Value = iCell.Value
    Next iCell
    Debug.Print "5. Written to '" _
        & Intersect(irg.EntireRow, drg).Address(0, 0) & "'."

    'Or:
    ' Write to whole destination range.
    'drg.Value = srg.Value
    'Debug.Print "5. Written to '" & drg.Address(0, 0) & "'."

SafeExit:
    Application.EnableEvents = True
    Debug.Print "6. Events enabled. Exiting."

    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

' Multi-range example. Best run from 'VBE' with the Immediate window open.
Sub Test()
    Range("C71,C73,C75").Value = "A"
    Range("C73,C75").Value = "B"
    Range("C75").Value = "C"
End Sub
  • Related