Worksheet Change - Target Range & changes to more than one other cell

[starsky]

Hi,

I'm trying to set up a worksheet so that if a user selects 'Yes' from a drop down box in column D the value 'n/a' will be applied to the next 4 cells (in columns E,F,G,H) in same row row. Otherwise a small drop down list will be created in each of those next 4 cells.

So far I can make this work fine for one Target cell (D7). I would like it to work for all cells in a Target range of "D71000".

With regard to applying changes to 4 offset cells, instead of 1 as below, I've run into problems when I've declared more than one range and tried to execute the code - Excel appears to freeze and there is flickering in the few cells with anything in them.

Any solutions would be wonderful.

Thanks.


[VBA]
Private Sub Worksheet_Change(ByVal Target As Range)

Dim rg1 As Range

Set Target = Range("D7")
Set rg1 = Target.Offset(0, 1)

If Target = "Yes" Then
rg1.Value = "n/a"
Else: With rg1.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$Q$7:$Q$9"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End Sub
[/VBA]

[mdmackillop]

[VBA]rg1.Resize(,4).Value = "n/a" [/VBA]

[starsky]

Ok, I've progressed since my last post. My current code is below. It does what I want it to. However, if a user selects more than one cell in the Target range, eg to delete entries, then a runtime error 13 occurs. Is there a way can I ask the sub to do nothing if the target range is greater than one cell?

Any tidy up tips welcome too.

Thanks

[VBA]Private Sub Worksheet_Change(ByVal Target As Range)
Dim rg1 As Range
Dim rg2 As Range
Dim rg3 As Range
Dim rg4 As Range

If Target.Row > 6 And Target.Column = 4 Then

Set rg1 = Target.Offset(0, 1)
Set rg2 = Target.Offset(0, 2)
Set rg3 = Target.Offset(0, 3)
Set rg4 = Target.Offset(0, 4)

If Target = "Yes" Then

rg1.Value = "n/a"
rg2.Value = "n/a"
rg3.Value = "n/a"
rg4.Value = "n/a"

Else:
With rg1.ClearContents
End With
With rg2.ClearContents
End With
With rg3.ClearContents
End With
With rg4.ClearContents
End With

With rg1.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$Q$7:$Q$9"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
With rg2.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$Q$7:$Q$9"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
With rg3.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$Q$7:$Q$9"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
With rg4.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$Q$7:$Q$9"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End If
End Sub[/VBA]

[starsky]

Great tip mdmackillop, thanks. I've applied it to each instance where I've repeated code for rg1, etc.

[mdmackillop]

Is there a way can I ask the sub to do nothing if the target range is greater than one cell?

Exactly what you said!
[VBA]
If Target.Cells.Count >1 Then Exit Sub
[/VBA]

[starsky]

Works a treat. Thanks for your help.