Constantly running loop

[doreilly2409]

Hi

I am running a code which creates a red circle over a cell when a condition is met ("yes" appears in the cell). The problem is the cell, in Column I, is controlled by a drop down being selected in a corresponding cell in column D. The loop continues to run when any cell in the work sheet is clicked meaning multiple red circles are placed, one on top of the other.

I want the code to be constantly running but only create the circle once. I know its something to do with events being updated etc but I can't quite crack it. Any help would be greatly welcomed. Please see my code below

Thanks
Dan

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet
Dim cell As Range
Dim searchText As String
Dim shp As Shape

Set ws = ThisWorkbook.Sheets("Heat Map")
searchText = "yes"


For Each cell In ActiveSheet.Range("i9:i28")
If InStr(1, cell.Value, searchText, vbTextCompare) > 0 Then
Set shp = ws.Shapes.AddShape(msoShapeOval, cell.Left, cell.Top, cell.Width, cell.Height)

With shp
.Line.ForeColor.RGB = RGB(255, 0, 0)
.Line.Weight = 1
.Fill.Transparency = 1

End With
End If
Next cell
End Sub

 

[MikeVol]

Hello @doreilly2409. Perhaps I misunderstood the question. Try next modification.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell        As Range
    Dim shp         As Shape
    Dim shpName     As String

    If Not Intersect(Target, Me.Range("I9:I28")) Is Nothing Then
        Application.EnableEvents = False

        For Each cell In Target
            shpName = "shp_" & cell.Address(False, False)

            On Error Resume Next
            Set shp = Me.Shapes(shpName)
            On Error GoTo 0

            If LCase(cell.Value) = "yes" Then
                
                If shp Is Nothing Then
                    Set shp = Me.Shapes.AddShape(msoShapeOval, cell.Left, cell.Top, cell.Width, cell.Height)
                    
                    With shp
                        .Name = shpName
                        .Line.ForeColor.RGB = RGB(255, 0, 0)
                        .Line.Weight = 1
                        .Fill.Transparency = 1
                    End With
                
                End If
            
            Else
                If Not shp Is Nothing Then shp.Delete
            End If
        
        Next cell

        Application.EnableEvents = True
    End If

End Sub

I hope I was able to help you. Good luck.

 

[doreilly2409]

Hello @doreilly2409. Perhaps I misunderstood the question. Try next modification.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell        As Range
    Dim shp         As Shape
    Dim shpName     As String

    If Not Intersect(Target, Me.Range("I9:I28")) Is Nothing Then
        Application.EnableEvents = False

        For Each cell In Target
            shpName = "shp_" & cell.Address(False, False)

            On Error Resume Next
            Set shp = Me.Shapes(shpName)
            On Error GoTo 0

            If LCase(cell.Value) = "yes" Then
               
                If shp Is Nothing Then
                    Set shp = Me.Shapes.AddShape(msoShapeOval, cell.Left, cell.Top, cell.Width, cell.Height)
                   
                    With shp
                        .Name = shpName
                        .Line.ForeColor.RGB = RGB(255, 0, 0)
                        .Line.Weight = 1
                        .Fill.Transparency = 1
                    End With
               
                End If
           
            Else
                If Not shp Is Nothing Then shp.Delete
            End If
       
        Next cell

        Application.EnableEvents = True
    End If

End Sub

I hope I was able to help you. Good luck.

Hi Mike,

I appreciate the response but I don't think I've correctly explained the problem.

Whenever I update, for example, Cell D9 it places a red circle around cell i9 that I can then move over a picture to highlight the issue described in cell D9.

The problem I have in my code is once that red circle appears and I click to a new cell a duplicate circle appears because there is still text in D9 (which needs to stay there)

I only want the circle to appear once when cell d9 is changed for the first time.

Hope I've explained it better

Thanks
Dan

 

[MikeVol]

Show me an example of how it is and how it should be. I don't understand you, I need to see.