VBA 大量の画像を指定の場所に貼り付ける際に成功するときとエラーが発生するときがある

Question

前提・実現したいこと

保存されている画像をExcelシートの指定の場所に貼り付ける。

簡単な説明として、
・Excelには「input」「チェックシート」の2つのシートがあります。
・「input」には画像の格納先のパスを入力する場所(B4セル)とマクロ実行のボタンがあります。
・「チェックシート」には画像のファイル名(拡張子なし)がF列に書かれている。
・今回はG列に画像を貼り付けていきたい。その時、左(F列)の名前と画像の名前が一致したとき、G列に貼り付けたい。

発生している問題・エラーメッセージ

現在エラー文で、
 実行エラー’91’;
オブジェクト変数またはWith変数が設定されていません。
となってしまいました。
Cells.Find(What:=strImgName).Activateの部分が色塗りされている状態です。
 何が原因かわかりませんか？ 

少し調べたところ、nothingの場合の処理を入れるといいみたいなのですが、
nothingの場合はH列に「NG」と入力するようにしたいです。
ネットで調べると、
Set r = Cells.Find("test")
If Not r Is Nothing Then
のような書き方でsetが使われていますが、
自分のは違う書き方になっているので対処方法がわかりません。
また、
Set objShape = からの動作もネットから持ってきたもので、H列に入力する処理方法もわからないので
教えていただけませんか？

該当のソースコード

Private Sub CommandButton1_Click()
    Call call_PasteImage
End Sub

'****************************************************************
' グローバル変数
'****************************************************************

'【Path取得セル】"INPUT"シート
Public Const pathClm As Integer = 2 'B
Public Const pathRow As Integer = 4

Dim ImagePath As String ' 貼り付け用画像格納フォルダパス

Function call_PasteImage()
Dim objShape As Object
Dim strFileName As String
Dim strImgName As String

ImagePath = Cells(pathRow, pathClm)
strFileName = Dir(Range("B4").Value & "*.jpg")

Sheets("チェックシート").Select
 
    Do Until Len(strFileName) = 0
        strImgName = Left(strFileName, Len(strFileName) - 4)
        
        Cells.Find(What:=strImgName).Activate
            ActiveCell.Offset(0, 1).Activate
    
        Set objShape = ActiveSheet.Shapes.AddPicture( _
                        fileName:=ImagePath & strFileName, _
                        LinkToFile:=False, _
                        SaveWithDocument:=True, _
                        Left:=ActiveCell.Left, _
                        Top:=ActiveCell.Top, _
                        Width:=ActiveCell.Width, _
                        Height:=ActiveCell.Height)
        
        strFileName = Dir()
    Loop
 
End Function

試したこと

ここに問題に対して試したことを記載してください。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Comments

[Y.H.]

こっち↓の質問は放置ですか？
https://teratail.com/questions/228799

[kitagawasho]

すみません。そちらの回答を見落としていました、、、
自分で調べてnothingが返されてその処理が書かれていないのでエラーになると思い、nothingが返された時の処理を付け足そうと思って今回質問をしました

Answer 1

一つ前に投稿されていた質問に書かれていた返答にあるとおり

Cells.Findは検索したけど見つからなかった場合に、
Nothingを返すのでActivateがエラーになります。

この点の問題が解決されていないためであるように思われます。

Cells.Find(What:=strImgName).Activate

「Ctrl + F」で出てくる「検索と置換」ダイアログと
同じ機能をCells.Findを用いて稼動させています。

Cells.FindではRange型を返してきますので、検索対象の文字列（この場合、strImgName）を
シート内にて検索した結果、見つかったのでそのセルの座標（例えば、A1、とか）が返ってきて、
そのセルをActivateしています。
見つからなかったら、「nothing」が返されます。
「nothing」ではセルの座標にならないのでエラーになっています。

---

ネットで調べると、～

の内容はたぶん正解なのだと思います。その前提で。

Dim FoundCell As Range

↑Dimの並んでいる所、strImgNameの下にでも追加。

   Do Until Len(strFileName) = 0
        strImgName = Left(strFileName, Len(strFileName) - 4)

        Set FoundCell = Cells.Find(What:=strImgName)

        If FoundCell Is Nothing Then
            cells(Activecell.row,"H").value = "NG"  'この行は適宜修正してください

        Else
            ActiveCell.Offset(0, 1).Activate

            Set objShape = ActiveSheet.Shapes.AddPicture( _
                fileName:=ImagePath & strFileName, _
                LinkToFile:=False, _
                SaveWithDocument:=True, _
                Left:=ActiveCell.Left, _
                Top:=ActiveCell.Top, _
                Width:=ActiveCell.Width, _
                Height:=ActiveCell.Height)

                strFileName = Dir()
        End If

    Loop

↑Do～Loopの内側だけを最小限にだけ修正してみました。上記2点です。

ここまで書きましたが全体的に不明な点もありますので
私のも正しいかちょっと分からない感じです(^^;
動作確認しながら必要な箇所は修正してください。

Office TANAKA - セルの検索