On Error Resume Next

Public Sub InsPict()
    Dim fldPath$, art$, fName$, i&, r0&, lrow&, iShape As Shape, Zm, dat
    For Each iShape In ActiveSheet.Shapes
        If iShape.Type <> 8 Then iShape.Delete
    Next
    fldPath = "C:\IMG\" 'ThisWorkbook.Path & "\images\"       'путь к папке с изображениями
    r0 = 2
    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    Application.ScreenUpdating = False
    On Error Resume Next
    For i = r0 To lrow
        If Cells(i, "A") <> "" Then
            fName = Dir(fldPath & Cells(i, "A") & "\*.jpg")
            dat = FileDateTime(fldPath & Cells(i, "A") & "\" & fName)
            Do While fName <> ""
                fName = fldPath & Cells(i, "A") & "\" & fName
                If FileDateTime(fName) <= dat Then
                    If ActiveSheet.Shapes(ActiveSheet.Shapes.Count).TopLeftCell.Top = ActiveCell.Top Then ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Delete
                    art = Split(fName, ".")(0)
                    With Cells(i, "B")
                        Set iShape = ActiveSheet.Shapes.AddPicture(fName, False, True, .Left + 1, .Top + 1, -1, -1)
                        Zm = WorksheetFunction.Min(.Width / iShape.Width, .Height / iShape.Height)
                        iShape.Height = iShape.Height * Zm - 2
                    End With
                    dat = FileDateTime(fName)
                End If
                fName = Dir
            Loop
        End If
    Next i
    Application.ScreenUpdating = True
End Sub