Bright01
asked on
Macro Firing Cell Change
EE Pros,
Happy holidays!
I have a Macro that fires when a change is made to cell B1 (in WS2). I have modified the Workbook so that I have a Worksheet that has the change I want to make to B1 on a different sheet (Sheet1, Cell D5). When I input the text into cell D5, I want it to reflect the change in cell B1 and have the macro fire. Unfortunately, as you may see with the code below, I have to reinter the same data into B1 (WS2). In otherwords, I need the simple fix of how to reflect a change in Sheet1, Cell D5 into cell B1; then have the Macro fire.
That's it!
Thank you in advance,
B.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err
Dim rgWidth As Range, rgInitialize As Range, targ As Range
Dim rng1 As Range, rng2 As Range
Dim rng1LastRow As Long, rng2LastRow As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
'Watch this cell for changes
Set targ = Range("B1")
'Reinitialize these cells if the watched cell changes
Set rgInitialize = Union(Range("A3:A50"), Range("C3:C50"))
'Change the column width of these cells as data changes
Set rgWidth = Union(Range("B3:B50"), Range("D3:D50"))
rgWidth.EntireColumn.AutoF it
If Intersect(targ, Target) Is Nothing Then Exit Sub
rgInitialize.ClearContents
rng1LastRow = Range("B" & Rows.Count).End(xlUp).Row
rng2LastRow = Range("D" & Rows.Count).End(xlUp).Row
Set rng1 = Range("B1:B" & rng1LastRow)
Set rng2 = Range("D1:D" & rng2LastRow)
If Not Intersect(Target, rng1) Is Nothing Then
With Range("A" & Target.Row).Validation
.Delete
If Len(Trim(Target.Value)) <> 0 Then
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertSt op, Operator:= _
xlBetween, Formula1:="H,M,L"
End If
End With
ElseIf Not Intersect(Target, rng2) Is Nothing Then
With Range("C" & Target.Row).Validation
.Delete
If Len(Trim(Target.Value)) <> 0 Then
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertSt op, Operator:= _
xlBetween, Formula1:="H,M,L"
End If
End With
End If
Sidz:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
Err:
MsgBox Err.Description
GoTo Sidz
End Sub
Happy holidays!
I have a Macro that fires when a change is made to cell B1 (in WS2). I have modified the Workbook so that I have a Worksheet that has the change I want to make to B1 on a different sheet (Sheet1, Cell D5). When I input the text into cell D5, I want it to reflect the change in cell B1 and have the macro fire. Unfortunately, as you may see with the code below, I have to reinter the same data into B1 (WS2). In otherwords, I need the simple fix of how to reflect a change in Sheet1, Cell D5 into cell B1; then have the Macro fire.
That's it!
Thank you in advance,
B.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err
Dim rgWidth As Range, rgInitialize As Range, targ As Range
Dim rng1 As Range, rng2 As Range
Dim rng1LastRow As Long, rng2LastRow As Long
Application.EnableEvents = False
Application.ScreenUpdating
'Watch this cell for changes
Set targ = Range("B1")
'Reinitialize these cells if the watched cell changes
Set rgInitialize = Union(Range("A3:A50"), Range("C3:C50"))
'Change the column width of these cells as data changes
Set rgWidth = Union(Range("B3:B50"), Range("D3:D50"))
rgWidth.EntireColumn.AutoF
If Intersect(targ, Target) Is Nothing Then Exit Sub
rgInitialize.ClearContents
rng1LastRow = Range("B" & Rows.Count).End(xlUp).Row
rng2LastRow = Range("D" & Rows.Count).End(xlUp).Row
Set rng1 = Range("B1:B" & rng1LastRow)
Set rng2 = Range("D1:D" & rng2LastRow)
If Not Intersect(Target, rng1) Is Nothing Then
With Range("A" & Target.Row).Validation
.Delete
If Len(Trim(Target.Value)) <> 0 Then
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertSt
xlBetween, Formula1:="H,M,L"
End If
End With
ElseIf Not Intersect(Target, rng2) Is Nothing Then
With Range("C" & Target.Row).Validation
.Delete
If Len(Trim(Target.Value)) <> 0 Then
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertSt
xlBetween, Formula1:="H,M,L"
End If
End With
End If
Sidz:
Application.ScreenUpdating
Application.EnableEvents = True
Exit Sub
Err:
MsgBox Err.Description
GoTo Sidz
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thank you! Works perfectly.......... Have a great holiday.
All the best,
B.