Sub AddPics()
    Dim ws1 As Worksheet
    Dim ws3 As Worksheet
    Dim c As Range, i As Long
    Dim FA As String
    Dim dict As Object, key
    
    Set ws1 = Worksheets("KARDEX_PRINTOUT")
    Set ws3 = Worksheets("pics")
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set rng = ws1.Range("B7:Q17")
    For Each cel In rng.SpecialCells(xlCellTypeConstants)
        For i = 1 To 9
            If InStr(1, cel, "z." & i) Then
                If Not dict.exists(cel.Formula) Then dict.Add cel.Formula, CStr(i)
            End If
        Next i
    Next cel
    
    Call ClearPics(ws1)
    
    With ws1.Cells
        For Each key In dict.Keys
            Set c = .Find(key, lookat:=xlWhole)
            If Not c Is Nothing Then
                FA = c.Address
                Do
                    ws3.Shapes("Picture " & dict(key)).Copy
                    c.PasteSpecial xlPasteAll
                    Set c = .FindNext
                Loop While Not c Is Nothing And FA <> c.Address
            End If
        Next key
    End With
End Sub


Sub ClearPics(ws1 As Worksheet)
    Dim s As String
    Dim pic As Shape
    Dim rng As Range
    
    Set rng = ws1.Range("B7:Q17")
    For Each pic In ws1.Shapes
        With pic
            s = .TopLeftCell.Address & ":" & .BottomRightCell.Address
        End With
        If Not Intersect(rng, ws1.Range(s)) Is Nothing Then
            pic.Delete
        End If
    Next
End Sub