View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.worksheet.functions
Toppers Toppers is offline
external usenet poster
 
Posts: 4,339
Default 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"