VBAで画像を取り込む高速で画像自体を取得しエクセルに貼り付ける

Sub 案件1_改良_実行()
'1_変数の宣言
Dim base_path As String 'ファイルパスを格納　セルA3の値に￥をつけた
Dim file_name As String  'ファイル名を格納
Dim file_path As String  '上2つの変数をセットにしたもの
Dim i As Long: i = 2 ' 貼付け位置を管理する変数
Dim FSO As Object ' ファイルシステムオブジェクト　フォルダを扱う為の変数
Dim s_fd As Object  '現状掴んでるフォルダを格納する変数
Dim rng As Range '貼り付けるセルを決める為の変数
'***********************************************
'2_画面更新をコントロール（少しでも作業を減らして速度を上げる為）
Application.ScreenUpdating = False
'***********************************************
    '3_フォルダ周回用のループを作成
    'ファイルシステムオブジェクトはオブジェクトなのでSetが必要
    Set FSO = CreateObject("Scripting.FileSystemObject")
    'セルA3に書いてあるパスに存在するフォルダの中に居るフォルダを順番に選択
    For Each s_fd In FSO.GetFolder(Cells(3, 1)).subfolders
    
      'file_pathを作る為の準備
        base_path = s_fd & "\"
        file_name = Dir(base_path, vbNormal)
        file_path = base_path & file_name
        '4_ファイル名のキーワードを確認
        '変数file_nameが無くなるまでループします
        Do Until file_name = ""
            '変数file_nameの中に　_get　が居るか？
            If file_name Like "*_get*" Then
           
　　　　　　　 '5_画像を貼りつけるセルを変数rngにセット
              Set rng = Cells(i + 3, 1)
               
               '6_画像を取得する
               'AddPictureメソッドを使う
               '1回引数を指定しないといけない
               'LeftTopはセル起点、widthHeightはゼロで仮置き
              With rng.Worksheet.Shapes.AddPicture(fileName:=file_path, _
                                                 LinkToFile:=False, _
                                                 SaveWithDocument:=True, _
                                                 Left:=rng.Left, _
                                                 Top:=rng.Top, _
                                                 Width:=0, _
                                                 Height:=0)
                                                                                        
                                        
                    'Shapeプロパティへの処理
                    .LockAspectRatio = True '縦横比固定
                    .Placement = xlMoveAndSize '移動&サイズ変更

                    '縦を元のサイズを起点に100% = 元の画像と同じサイズ
                    .ScaleHeight 1, msoTrue 
                    '横を元のサイズを起点に100% = 元の画像と同じサイズ
                    .ScaleWidth 1, msoTrue
                
                    '7_画像がセルの中心に配置される様に位置と大きさを調整
                    '画像のサイズがセルの「幅-2」より大きかったら・・・
                    If .Width > rng.Width - 2 Then  

                        '画像の幅はセル「幅-2」に変更する
                        .Width = rng.Width - 2  
                    End If
                    '画像のサイズがセルの「高さ-2」より大きかったら・・・ 
                    If .Height > rng.Height - 2 Then 

                        '画像の幅はセル「高さ-2」に変更する
                        .Height = rng.Height - 2  
                    End If
                
                    '画像をセル高さ方向の中心にセット
                    .Top = .Top + ((rng.Height - .Height) / 2) 

                    '画像をセル幅方向の中心にセット
                    .Left = .Left + ((rng.Width - .Width) / 2)  
                        
                End With
    
                i = i + 1
            
            End If
            '8_次の画像を確認する為の処理
            'Dir関数でフォルダ内に居る次のファイルを掴む
            'ファイル名を変数file_nameにセット
            file_name = Dir()
            '変数file_pathに次のファイル名をセットする
            file_path = base_path & file_name
            
        'Doまで戻る
        Loop
    Next s_fd
'***********************************************
'2_画面更新を止める　を解除
Application.ScreenUpdating = True
'***********************************************
'9_作業終了の報告
MsgBox "処理が完了しました", , "作業完了"
End Sub