....
    With Application
        .ScreenUpdating = False
        .calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayStatusBar = False
        .DisplayAlerts = False
   End With

For r = 2 To 3000
      If oSH.Cells(r, 2) <> "" Then _
        Call fun_InsertPicture(oSH, oSH.Cells(r, 2), oSH.Cells(r, 1),45)
Next

    With Application
        .ScreenUpdating = True
        .calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayStatusBar = True
        .DisplayAlerts = True
   End With
....


Public Function fun_InsertPicture(ByVal oWS As Worksheet _
                                 ,ByVal Article As String _
                                 ,ByVal oRange As range _
                                 ,ByVal SizePicture As Double)
Dim oShape As Shape
       
'PathPicture переменная там путь к папке на сетевом диске
On Error GoTo err
    Article = PathPicture & Article & ".jpg"
    With oRange
       oWS.Shapes.AddPicture(Article, msoTrue, msoTrue, .Left + 1, .Top + 1, SizePicture, SizePicture)
    End With

    Exit Function
err:
    Exit Function

End Function