Show hide Shapes based on cell value in vba

I have 20 shapes in my ** Active sheet**.

There names are following Item-1, Item-2, Item-3, . . . . . . . . till Item-20.

And a sheet6 or which sheet name is ITEM has item names in Range F2:F21.

Below VBA code is working fine.

But the code is too much long.

I have no idea how to make this code smaller?

Private Sub Group_1()
On Error Resume Next

    If Sheet6.Range("F2").Value = "" Then
    ActiveSheet.Shapes("Item-1").Visible = False
    Else
    ActiveSheet.Shapes("Item-1").Visible = True
    End If
    
    If Sheet6.Range("F3").Value = "" Then
    ActiveSheet.Shapes("Item-2").Visible = False
    Else
    ActiveSheet.Shapes("Item-2").Visible = True
    End If
    
    If Sheet6.Range("F4").Value = "" Then
    ActiveSheet.Shapes("Item-3").Visible = False
    Else
    ActiveSheet.Shapes("Item-3").Visible = True
    End If
    
    If Sheet6.Range("F5").Value = "" Then
    ActiveSheet.Shapes("Item-4").Visible = False
    Else
    ActiveSheet.Shapes("Item-4").Visible = True
    End If

    ' And So On till Item-20

    ActiveSheet.Shapes.Range(Array("Item-1")).Select
    Selection.Formula = "=ITEM!F2"
    Range("A1").Select
    
    ActiveSheet.Shapes.Range(Array("Item-2")).Select
    Selection.Formula = "=ITEM!F3"
    Range("A1").Select
    
    ActiveSheet.Shapes.Range(Array("Item-3")).Select
    Selection.Formula = "=ITEM!F4"
    Range("A1").Select
    
    ActiveSheet.Shapes.Range(Array("Item-4")).Select
    Selection.Formula = "=ITEM!F5"
    Range("A1").Select
' And so on till Item-20
End Sub

When I run this above code. It inserts Cell contents to My shapes From the Range Sheet6.Range("F2:F21") or Sheets("ITEM").Range("F2:F21").

But, if a cell F2 from Sheet6 is empty then Shape Item-1 from my ActiveSheet must be hidden. if a cell F3 from sheet6 is empty then Shape Item-2 must be hidden. and so on.

Please help and guide.

Solution

WE should avoid selecting Objects (Cells, Sheets, Shapes, ...ect.) whenever possible.
Watch: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)

Private Sub Group_1()
    Dim n As Long
    Dim sh As Shape
    Dim Cell As Range

    Rem Target range: Sheet6, starting at F2, resizing for 20 rows
    With Sheet6.Range("F2").Resize(20)
        For n = 1 To 20
            Rem Set the current cell in the range (F2:F21)
            Set Cell = .Cells(n, 1)

            Rem Attempt to set the shape named "Item-n"
            Set sh = ActiveSheet.Shapes("Item-" & n)

            Rem Check if the shape exists (sh is not Nothing)
            If Not sh Is Nothing Then
                Rem Set shape visibility based on whether the cell has content
                Rem This works because 0 evaluates as FALSE and any otehr value TRUE
                sh.Visible = Len(Cell.Value)
                
                Rem Set the shape formula to link with the corresponding cell
                sh.OLEFormat.Object.Formula = "=ITEM!" & Cell.Address(0, 0)
            Else
                Rem If the shape is not found, print a debug message
                Debug.Print "Shape 'Item-" & n & "' not found."
            End If

            Rem Reset error handling
            On Error GoTo 0
        Next n
    End With
End Sub