Private Sub ва ()
ActiveWorkbook.RefreshAll
End Sub

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Workbooks.Open Filename:="C:\Users\11\222\333\444\foto.xlsx"
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

Option Explicit
Public Sub InsPict()
Dim arr, fldPath$, art$, fName$, i&, r0, lrow&, oDic As Object, IShape As Shape, Zm
Set oDic = CreateObject("Scripting.Dictionary")
r0 = 4
lrow = Cells(Rows.Count, 3).End(xlUp).Row
arr = Cells(r0, 3).Resize(lrow - r0 + 1).Value
For i = 1 To UBound(arr)
oDic(arr(i, 1)) = i + r0 - 1
Next i
For Each IShape In ActiveSheet.Shapes
If IShape.Type <> 8 Then On Error Resume Next
Next
fldPath = ThisWorkbook.Path & "\images\"    путь к папке
Application.ScreenUpdating = False
fName = Dir(fldPath & "*.jpg")
Do While fName <> ""
art = Split(fName, ".")(0)
If oDic.Exists(art) Then
With Cells(oDic(art), 2)
Set IShape = ActiveSheet.Shapes.AddPicture(fldPath & 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
End If
fName = Dir
Loop
Application.ScreenUpdating = True
End Sub

Sub InsertPicToCell()
    Const sPicsPath$ = "G:\Документы\Изображения\"
    Dim sPicName$, sPFName$
    Dim IShape As Shape
    Dim zm#
    
    sPicName = Range("B12").Value
    If sPicName = "" Then
        Exit Sub
    End If
    sPFName = sPicsPath & sPicName
    If Dir(sPFName, 16) = "" Then
        Exit Sub
    End If
    With Sheets(2).Range("D99")
        Set IShape = Sheets(2).Shapes.AddPicture(sPFName, False, True, .Left+1, .Top+1, -1, -1)
        zm = Application.Min(.Width / IShape.Width, .Height / IShape.Height)
        IShape.Height = IShape.Height * zm - 2
    End With
End Sub

Sub InsertPicToCell()
    Const sPicsPath$ = "G:\Документы\Изображения\"
    Dim sPicName$, sPFName$, sSpName$
    Dim IShape As Shape
    Dim zm#
    
    sPicName = Range("B12").Value
    If sPicName = "" Then
        Exit Sub
    End If
    sPFName = sPicsPath & sPicName
    If Dir(sPFName, 16) = "" Then
        Exit Sub
    End If
    
    With Sheets(2).Range("D99")
        On Error Resume Next
        sSpName = "_" & .Address(0, 0) & "_autopaste"
        Set IShape = Sheets(2).Shapes(sSpName)
        If Not IShape Is Nothing Then
            IShape.Delete
        End If
        Set IShape = Sheets(2).Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
        zm = Application.Min(.Width / IShape.Width, .Height / IShape.Height)
        IShape.Height = IShape.Height * zm - 2
        IShape.Name = sSpName
    End With
End Sub