質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

88.19%

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

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 1,141

kitagawasho

score 21

前提・実現したいこと

保存されている画像を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/ツールのバージョンなど)

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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • Y.H.

    2019/12/12 11:12

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

    キャンセル

  • kitagawasho

    2019/12/12 11:25

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

    キャンセル

回答 1

checkベストアンサー

0

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

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 - セルの検索

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 88.19%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る

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