Macro looping endlessly
try:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
On Error GoTo ws_exit
Application.EnableEvents = False
For Each myCell In Range("C13:G13,M13:Q13")
If myCell.Value = "Miss" Then
With myCell.Offset(1)
.Interior.ColorIndex = 36 'Light Yellow
.BorderAround LineStyle:=xlContinuous,
Weight:=xlThin, _
ColorIndex:=11
With .Validation
.Delete
.Add Type:=xlValidateList,
Formula1:="Left,Right,Short,Long"
.IgnoreBlank = True
.InCellDropdown = True
End With
End With
With myCell.Offset(2)
.Interior.ColorIndex = 36 'Light Yellow
.BorderAround LineStyle:=xlContinuous,
Weight:=xlThin, _
ColorIndex:=11
With .Validation
.Delete
.Add Type:=xlValidateList, Formula1:="Yes,No"
.IgnoreBlank = True
.InCellDropdown = True
End With
End With
With myCell.Offset(3)
.Interior.ColorIndex = 36 'Light Yellow
.BorderAround LineStyle:=xlContinuous,
Weight:=xlThin, _
ColorIndex:=11
With .Validation
.Delete
.Add Type:=xlValidateList, Formula1:="Yes,No"
.IgnoreBlank = True
.InCellDropdown = True
End With
End With
With myCell.Offset(1).Resize(3, 1)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue,
Operator:=xlGreater, _
Formula1:="0"
.FormatConditions(1).Font.ColorIndex = 2
.FormatConditions(1).Interior.ColorIndex = 11
End With
End If
If myCell.Value = "Hit" Then
With myCell.Offset(1).Resize(3, 1)
.Interior.ColorIndex = 11
.ClearContents
With .Validation
.Delete
End With
End With
End If
Next
ws_exit:
Application.EnableEvents = True
End Sub
"Sandy" wrote:
Full code added below
"Sandy" wrote in message
...
Hi
The following resets the cell interior to Dark Blue - which is fine
If myCell.Value = "Hit" Then
With myCell.Offset(1).Resize(3, 1)
.Interior.ColorIndex = 11
With .Validation
.Delete
End With
End With
End If
However I need to clear the contents of the cells too - if I do this
If myCell.Value = "Hit" Then
With myCell.Offset(1).Resize(3, 1)
.Interior.ColorIndex = 11
.ClearContents
With .Validation
.Delete
End With
End With
End If
it goes into an endless loop. Any suggestions
Sandy
Here is the full macro if it helps
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
For Each myCell In Range("C13:F13,M13:P13")
If myCell.Value = "Miss" Then
With myCell.Offset(1)
.Interior.ColorIndex = 36
.BorderAround LineStyle:=xlContinuous,
Weight:=xlThin, _
ColorIndex:=11
With .Validation
.Delete
.Add Type:=xlValidateList,
Formula1:="Left,Right,Short,Long"
.IgnoreBlank = True
.InCellDropdown = True
End With
End With
With myCell.Offset(2)
.Interior.ColorIndex = 36
.BorderAround LineStyle:=xlContinuous,
Weight:=xlThin, _
ColorIndex:=11
With .Validation
.Delete
.Add Type:=xlValidateList, Formula1:="Yes,No"
.IgnoreBlank = True
.InCellDropdown = True
End With
End With
With myCell.Offset(3)
.Interior.ColorIndex = 36
.BorderAround LineStyle:=xlContinuous,
Weight:=xlThin, _
ColorIndex:=11
With .Validation
.Delete
.Add Type:=xlValidateList, Formula1:="Yes,No"
.IgnoreBlank = True
.InCellDropdown = True
End With
End With
With myCell.Offset(1).Resize(3, 1)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue,
Operator:=xlGreater, Formula1:="0"
.FormatConditions(1).Font.ColorIndex = 2
.FormatConditions(1).Interior.ColorIndex = 11
End With
End If
If myCell.Value = "Hit" Then
With myCell.Offset(1).Resize(3, 1)
.Interior.ColorIndex = 11
With .Validation
.Delete
End With
End With
End If
Next
End Sub
I need to clear the contents in the 3 cells below each myCell containing
"Hit"
|