Detect image and fit row if not

[PIsabel]

Hello.
I'm working on a table of articles with images.
Each line has a fixed height of 100.
I need a code that identifies the lines that do not have an image and that reduces these same lines to a height of 15

Can some help me?

Thanks

 

[PIsabel]

Done!!!
It works impeccably well.
Thanks to everyone, especially "jolivanes"

Works on your example.

Sub Maybe()
Dim sh1 As Worksheet, shp As Shape, rng As Range, c As Range
Dim lr As Long, j As Long, rw
Set sh1 = Worksheets("Sheet1")
lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = sh1.Range(sh1.Cells(3, 1), sh1.Cells(lr, 1))
Application.ScreenUpdating = False
    With sh1
    For Each c In rng
        For Each shp In .Shapes
            If Not Intersect(shp.TopLeftCell, .Range(c.Address)) Is Nothing Then
                shp.Placement = xlMoveAndSize
                    rw = rw & "|" & c.Row
                Exit For
            End If
        Next shp
    Next c
    End With
    rw = Split(Mid(rw, 2), "|")
    For j = LBound(rw) To UBound(rw)
        sh1.Rows(rw(j)).EntireRow.Hidden = True
    Next j
    With rng
        .SpecialCells(xlCellTypeVisible).RowHeight = 15
        .EntireRow.Hidden = False
    End With
    Application.ScreenUpdating = True
End Sub

 

[jolivanes]

Thanks for the update and good luck

 

[jolivanes]

This might be more pleasing to the eye.

Sub Maybe_3()
Dim sh1 As Worksheet, rng As Range, lr As Long, c As Range, rws As Range
Set sh1 = Worksheets("Sheet1")
lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = sh1.Range(sh1.Cells(3, 1), sh1.Cells(lr, 1))
Application.ScreenUpdating = False
For Each c In rng
    If fcnHasImage(c) = False Then
        If Not rws Is Nothing Then
            Set rws = Union(rws, c.EntireRow)
                Else
            Set rws = c.EntireRow
        End If
    End If
Next c
If Not rws Is Nothing Then rws.RowHeight = 15
Set rws = Nothing
Application.ScreenUpdating = True
End Sub

Public Function fcnHasImage(ByVal Target As Range) As Boolean
    Dim bResult As Boolean, shp As Shape
    bResult = False
    If Not ActiveSheet.Shapes Is Nothing Then
        For Each shp In ActiveSheet.Shapes
            If shp.TopLeftCell.Address = Target.Address Then
                shp.Placement = xlMoveAndSize
                bResult = True
            End If
        Next shp
    End If
    fcnHasImage = bResult
End Function