Excelのパスが格納されている列の隣の列に画像を自動で表示させたい

Question

こんにちは。いつも過去ログを大変参考にさせていただいております。
今回も過去Q&Aを探したのですが、何分コーディングの基本を知らずに回答欄のコピペで済ましているため、自分で問題点を見つけることができません。

<質問内容＞
Bの列に画像のフルパスを入れてあります。その画像をAの列に自動で表示させるマクロボタンを作りたいのです。B列の２枚目までは上手く写真が表示されます。
しかし、パスが入っていない３列目はC:\NoPicture.jpgを表示させたいのですが、どうしてもそこで止まってしまい、
実行時エラー’1004:’
Picture クラスのInsert プロパティを取得できません。
とういうエラーメッセージが出ます。
正しいコードの書き方をどなたかお教えいただけますでしょうか？

＜問題点？＞
     'r.Item(1).Value = s
            With .Pictures.Insert(s).ShapeRange
この辺がうまくいっていないかと・・

＜シート内容＞
行　　列        
1　　A(画像表示)　　B(画像のフルパス)　　
2　　           　　　　　　　　　　C:	eet01.JPG
3　　       　　　　　　　　　　C:	eet02.JPG
4　　     　　　　　    　　　　　           (空白)
5        　　　　    　　　　　　　       C:	eet03.JPG
.
.
20　　    　　　　　 　　 　　　C:	eet19.JPG

＜マクロ文＞
Private Sub CommandButton1_Click()
    Const n As Long = 2 'margin
    Dim r As Range
    Dim i As Long
    Dim x As Double
    Dim s As String
  
    With ActiveSheet
       　　 For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row  '(B)セルは"2", 2行目から順にパスを取得
          　　　　  Set r = .Cells(i, 1).MergeArea                 '(A)セルは"1"
           　　　　 s = Cells(i, 2).Value                           
         　　　　   If Dir(s) = "" Then
          　　　　      s = "C:\NoPicture.jpg"    '画像が無い場合NoPicture画像を表示
         　　   Else
         　　　       Dir Application.Path
       　　     End If
         　　  'r.Item(1).Value = s
        　　    With .Pictures.Insert(s).ShapeRange
  　　              .LockAspectRatio = msoTrue            '縦横比固定
             　　   x = Application.Min(r.Width / .Width, r.Height / .Height)
        　　        If x < 1 Then .Width = .Width * 60 '画像の幅
              　　  .Left = r.Left + (r.Width - .Width) / 2  '画像を左右中央に配置
              　　  .Top = r.Top + (r.Height - .Height) / 2  '画像を上下中央に配置
        　　    End With
    　　    Next
 　   End With
  
   　 Set r = Nothing
End Sub

myRange · Accepted Answer

またまた登場、myRangeです。

＞顧客が「どうしてもエクセルでデータを欲しい」と言うことなので
＞恥ずかしながらお伺いしている次第です

質問することはなーんも恥ずかしいことではありませぬよ。
ただ、得た知識は必ずや自分のものにする、
という心意気が必須であることは言わずもがなのことですが。。。

では、本題。
CommandButtonのあるシートで実行するので、
かつ、画像はそのままでセルに嵌るということなので
より簡潔なコードにしてあります。

'----------------------------------------　
Private Sub CommandButton1_Click()
　　Dim R As Long
　　Dim myPic As String
　　Dim myCell As Range

For R = 2 To Cells(Rows.Count, 2).End(xlUp).Row
　　　　Set myCell = Cells(R, 1)
　　　　myPic = Cells(R, 2).Value
　　　　If myPic = "" Or Dir(myPic) = "" Then
　　　　　　myPic = "C:\aaa\NoPicture.jpg"
　　　　End If
　　　　With ActiveSheet.Pictures.Insert(myPic).ShapeRange
　　　　　　.Top = myCell.Top + (myCell.Height - .Height) / 2
　　　　　　.Left = myCell.Left + (myCell.Width - .Width) / 2
　　　　End With
　　Next
End Sub
'-------------------------------------

なお、明日、明後日と福岡への旅。
よってこれについての再質問は、今夜２３時３０分までに願います。
それか、月曜日に。。。
以上です。

myRange · Answer

>その消していたものが巨大なNoPictureでした。

当方が、質問者のコードが、ん？　と言ったのはそこらあたりも含まれています。
　
巨大の原因は、
　　 If x < 1 Then .Width = .Width * 60 '画像の幅
これです。
画像の高さ、幅、どちらかが、または、どちらも、セルの高さ、幅より大きかったら、
画像の幅を６０倍してますよね？

わぁーーー、巨大！(^^;;;

それを含めおかしいと思われる部分など修正したのが下記のコードです。
　
'----------------------------------------
Private Sub CommandButton1_Click()
　　Const n As Long = 2　　'●もともと未使用
　　Dim r As Range
　　Dim i As Long
　　Dim x As Double　　　　'●今回は使用しない
　　Dim s As String

With ActiveSheet
　　　For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row
　　　　　Set r = .Cells(i, 1)
　　　　　s = .Cells(i, 2).Value
　　　　　If Dir(s) = "" Then s = "C:\aaa\NoPicture.jpg"
　　　　　With .Pictures.Insert(s).ShapeRange
　　　　　　　Range("D1") = .Width / .Height
　　　　　　　.LockAspectRatio = msoTrue
　　　　　　　If .Width >= r.Width Then .Width = r.Width * 0.9
　　　　　　　If .Height >= r.Height Then .Height = r.Height * 0.9
　　　　　　　.Left = r.Left + (r.Width - .Width) / 2
　　　　　　　.Top = r.Top + (r.Height - .Height) / 2
　　　　　End With
　　　Next
　End With
End Sub
'------------------------------

画像の高さ、幅がセルのそれより大きかった場合は、セルの９０％にしてあります。

それから、質問提示のコードで、
Set r = .Cells(i, 1).MergeArea と、MergeAreaを使ってますが、
もし結合セルを扱うのであればコードが違ってくることは言うまでもありません。

それと画像全部を無条件にセルの９０％にするとかは拙いのでしょうか？
以上です。

myRange · Answer

回答１、myRangeです。

質問者のコードはコード的には、ん？　という部分もありますが、
そのままでもエラーは出ずに動作するコードです。
で、NoPicture.jpgないのでは？、との回答になりました。

目視での確認では間違いない、ということですから
再確認のため下記を試してみてください、間違いなく存在が確認できますので。

Ｂ列の任意のセル（Ｂ２が直ぐ確認できる）に
問題の画像のフルパス、"C:\NoPicture.jpg"　を入力してマクロを実行する。
存在すれば表示されるはずですよね。

但し、画像のフルパス、C:\NoPicture.jpg　は
手入力ではなく、現在のマクロからセルにコピペすること。
以上です。

myRange · Answer

＞パスが入っていない３列目はC:\NoPicture.jpgを表示させたいのですが
＞実行時エラー’1004:’
＞Picture クラスのInsert プロパティを取得できません。
＞とういうエラーメッセージが出ます。

Ｃドライブに、NoPicture.jpg　という名前の画像がないのでは？
チェックてみてください。
以上です。

Excelのパスが格納されている列の隣の列に画像を自動で表示させたい

またまた登場、myRangeです。

>その消していたものが巨大なNoPictureでした。

この回答への補足

回答１、myRangeです。

この回答への補足

＞パスが入っていない３列目はC:\NoPicture.jpgを表示させたいのですが

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング