こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

エクセルVBAで複数のセル入力からそれぞれの画像を指定したセルに貼り付け

複数のセル入力時のたびに自動実行されるイベントマクロを使い、それぞれの入力値と同じ画像を決まったセルに貼り付けようとするVBAをつくろうとしています。
画像サイズ加工(サイズ調整、トリミング)は同じものとします。
更に、画像がないセルに関しては、画像が挿入されるそれぞれのセルに
”画像登録がありません”と表示される。

入力セル=B3:B10 画像挿入セル=F2,F9,F16,F23,F30,F37,F44,F51

できれば、勉強の為に’コメント説明付のご回答をお願いします。

投稿日時 - 2009-05-29 20:43:53

QNo.5000860

困ってます

質問者が選んだベストアンサー

こんにちは。

>到底たどり着けないコードでした。

VBA力というのかな、囲碁などで言う、棋力と同じようにいうなら、それをすべてを組み入れられるのは、2段クラスぐらいかな?(どこかの県知事の名目剣道2段とはちょっと違います) 半年や1年のレベルでは、無理だと思います。ただ、この範囲は、掲示板での回答の範囲です。(そうでない場合は、お断りしているケースもあります)

でも、世の中は広いというか、怖いもので、プログラミングの経験がなくても、数ヶ月であっけなく上位クラスまで到達するような人もいます。ただ、一般的に簡単なBASIC コードでも、使いこなせられる人は、10人に1人だといわれていました。そういう私は、もうWindowsも扱うことはなかろうと思っていたのが、あるきっかけで、使い始めて、VBAも紆余曲折で覚えました。しかし、今、何年やっても、1週間もやっていないと、VBAがさび付いてきます。毎日のように、VBAのコードを触っていないとダメなのです。年のせいか、すべてのレベルが下降中です。(ここ数ヶ月パワーダウンしてしまっています)

>多くの変数宣言が必要なのですね。
掲示板のVBAの継続している回答者として、変数を宣言しないのは、みっともないのです。そうしないと指摘されることがあるからです。

>・入力セルとは、何を入れるのでしょうか?
> セルへの入力内容は、画像のファイル名を入力します
了解しましたが、もっとややこしいですね(^^;

>・次に、画像は一定のものですか?
> 一定のもので、"D:\写真\"というフォルダに複数の画像”・・・・.jpg"が入って います。
上の条件で、了解です。

>・画像が挿入される、という判定を画像でするのでしょうか?
> 判定は、入力セルの値と画像のファイル名の合致でおこないます。
>画像の判定で更に変数が必要でしょうか。

 変数自体は関係がありませんが、画像の判定の件は、ちょっと保留にしていただきたいのです。理由は、ファイル名は、AlternativeTextに書き込むようにしましたが、今の段階では、セル位置の対応があるようですから、セル位置の対応にしました。問題があるようなら、おっしゃってください。今のコードでは、画像を移動すると、処理できなくなります。画像のNameプロパティには入れるのはやめました。同じものを入れると、ぶつかってしてしまうからです。
 

'シートモジュール
'--------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Long
  Dim PicName As String
  Dim pic As Picture
  Dim arAD As Variant
  Dim c As Variant
  '画像の場所
  Const PICPATH As String = "D:\写真\"
  '挿入セルの場所
  Const arADD As String = "F2,F9,F16,F23,F30,F37,F44,F51"
    
  arAD = Split(arADD, ",")
  
  If Target.Count > 1 Then Exit Sub
  If Intersect(Target, Range("B3:B10")) Is Nothing Then Exit Sub
  i = (Target.Row - 3) * 7 + 2
  
  Application.ScreenUpdating = False
  If Target.Value <> "" Then
    PicName = Target.Value
    '拡張子の判定
    If InStr(1, PicName, ".jpg", 1) = 0 Then PicName = PicName & ".jpg"
    'ファイルの有無
    If Dir(PICPATH & PicName) = "" Then
     MsgBox PicName & " は、見つかりません。"
     Exit Sub
    End If
    With ActiveSheet.Pictures.Insert(PICPATH & PicName)
      .Top = Cells(i, 6).Top
      .Left = Cells(i, 6).Left
      'ファイル名を封入
      .ShapeRange.AlternativeText = PicName
    End With
  Else
    ClearPIC Cells(i, 6)
  End If
  Range(arADD).ClearContents
  Application.EnableEvents = False
  For Each c In Range(arADD)
    If IsPIC(c) = False Then
      c.Value = "画像登録がありません."
    End If
  Next c
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub
'
Private Function IsPIC(ByVal rng As Range)
'画像がセルにあるか判定する関数プロシージャ
Dim pic As Picture
Dim flg As Boolean
 flg = False
 For Each pic In ActiveSheet.Pictures
  With rng
   If Not Intersect(pic.TopLeftCell, rng) Is Nothing = True Then
    flg = True: Exit For
   End If
  End With
 Next pic
  IsPIC = flg
End Function
'
Private Function ClearPIC(ByVal rng As Range)
''画像を削除する関数プロシージャ
  Dim pic As Picture
  For Each pic In ActiveSheet.Pictures
    With rng
      If Not Intersect(pic.TopLeftCell, rng) Is Nothing = True Then
        pic.Delete
      End If
    End With
  Next pic
End Function


変更要点は部分は、順不同でよいので、思いつくまま箇条書きにして結構です。
ブロックごとに修正しますので、これ以上は、関数プロシージャか、イベント本体を分割してアップします。ただし、繰り返しで恐縮しますが、コメントアウトで解説するのは、コメントアウトもコードの一部ですので、後々、やりにくくなってしまいます。これは、謹んでお断りします。

投稿日時 - 2009-05-31 15:02:18

お礼

大変、大変ありがとうございました。
私のイメージした動きになりました。あとは本を見ながら、加工アレンジしてみます。

正直、ここまで親切、丁寧にタダで教えて頂ける方がいらっしゃるとは思いませんでした。
今、私の会社で取引しているベンダーさんなら、3人日の請求はされていたような
内容と思います。(^^;

本当に心より感謝いたします。ありがとうございました。

投稿日時 - 2009-05-31 21:39:29

ANo.3

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.2

こんにちは。

#1さんの言い方とは違いますが、掲示板は、あくまでも、質問している方のお手伝いするスタイルになっています。[丸投げ]という言葉が、どういうものか、また、ここのカテゴリの削除対象の規約にあるか分かりませんが、

しかし、質問が理路整然となっていれば、文章だけで、回答者が何も言わないでも、質問者に答えることは可能なのですが、今回のご質問では、不足した部分が多いのです。また、それ以上に、ご質問者さんが想像するよりも、遥かに難しい内容だからということもあるのですが。

それは、画像がセルの上に存在するかどうかは、画像の全部を当たらなければ判定できないのです。そういう判定のコードをイベントの中に置くというのは、あまり合理的なコードではありません。

>できれば、勉強の為に’コメント説明付のご回答をお願いします。

以下は、分からないところがあればお教えできますが、予め解説をいれるのはお断りします。理由は、ひとつは、回答は、教えるためではなく、あくまでも、自分のために書いているのですが、もうひとつは、必要以上のコメントを入れるというのは、自分のコーディング・スタイルを壊すことになるからです。コメントもひとつのコードの中にあるものです。あるレベルに達している人は、それなりに、自分のコーディング・スタイルを持っているものなのです。

>入力セルとは、何を入れるのでしょうか?
>次に、画像は一定のものですか?
>画像が挿入される、という判定を画像でするのでしょうか?

この部分がわかりませんので、こちらで、勝手に考えさせていただきました。なお、バージョンに依存する部分があるような気がします。今回は、Ver.2003 で開発しました。

'シートモジュール (シートタブから、コードの表示で貼り付ける)
'-----------------------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Long
  Dim pic As Picture
  Dim arAD As Variant
  Dim c As Variant
  '画像の場所
  Const PICNAME As String = "D:\My Pictures\goo.gif"
  '挿入セルの場所
  Const arADD As String = "F2,F9,F16,F23,F30,F37,F44,F51"
    
  arAD = Split(arADD, ",")
  
  If Target.Count > 1 Then Exit Sub
  If Intersect(Target, Range("B3:B10")) Is Nothing Then Exit Sub
  i = (Target.Row - 3) * 7 + 2
  
  Application.ScreenUpdating = False
  If Target.Value <> "" Then
    With ActiveSheet.Pictures.Insert(PICNAME)
      .Top = Cells(i, 6).Top
      .Left = Cells(i, 6).Left
    End With
  Else
    ClearPIC Cells(i, 6)
  End If
  Range(arADD).ClearContents
  Application.EnableEvents = False
  For Each c In Range(arADD)
    If IsPIC(c) = False Then
      c.Value = "画像登録がありません."
    End If
  Next c
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub
Private Function IsPIC(ByVal rng As Range)
'画像がセルにあるか判定する関数
Dim pic As Picture
Dim flg As Boolean
 flg = False
 For Each pic In ActiveSheet.Pictures
  With rng
   If Not Intersect(pic.TopLeftCell, rng) Is Nothing = True Then
    flg = True: Exit For
   End If
  End With
 Next pic
  IsPIC = flg
End Function
Private Function ClearPIC(ByVal rng As Range)
'画像を削除する関数プロシージャ
  Dim pic As Picture
  For Each pic In ActiveSheet.Pictures
    With rng
      If Not Intersect(pic.TopLeftCell, rng) Is Nothing = True Then
        pic.Delete
      End If
    End With
  Next pic
End Function

投稿日時 - 2009-05-30 12:04:02

お礼

大変ご丁寧な説明ありがとうございました。
VBAにチャレンジしたばかりで、質問内容もチンプンカンプンになってしまい、
申し訳ございません。やはり、多くの変数宣言が必要なのですね。
私には、到底たどり着けないコードでした。
補足として、セルへの入力内容は、画像のファイル名を入力します。
>入力セルとは、何を入れるのでしょうか?
 セルへの入力内容は、画像のファイル名を入力します
>次に、画像は一定のものですか?
 一定のもので、"D:\写真\"というフォルダに複数の画像”・・・・.jpg"が入って います。
>画像が挿入される、という判定を画像でするのでしょうか?
 判定は、入力セルの値と画像のファイル名の合致でおこないます。

画像の判定で更に変数が必要でしょうか。
ずうずうしい注文で、申し訳ありませんが、お時間の許す限りでご指導願います。

質問方法もやさしくお教えいただき感謝いたします。

投稿日時 - 2009-05-30 21:46:36

ANo.1

質問文を工夫すること。
B3:B10の1つのセルに画像ファイル名を入力すると、シートの対応するセルの位置にその画像を表示したい。
質問が丸投げ(規約違反)になっている。その上回答者に注文まで着いている。
ーー
こんなの挿入ー図ーファイルからのマクロの記録をとれば骨格は判る。質問の処理のためにコードのどこを変えればよいか考えること。
マクロの記録ぐらいとって勉強しましたか。
(1)シートのChangeイベントで処理のコードを囲む
(2)入力セルと画像位置の対応のセルの割り出しの一方法(参考)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Row >= 3 And Target.Row <= 10 Then
MsgBox Cells((Target.Row - 3) * 7 + 2, "F").Address
Else
MsgBox "範囲外"
End If
End Sub
をテストとしてやってみて、納得のこと。
(3)GOOGLEで
「エクセル 画像 挿入 VBA」で照会すればコード例もたくさん出る
事項だ。
Google照会などWEB照会して、勉強しましたか。
したのなら、質問が細かい点になるはず。

投稿日時 - 2009-05-29 22:11:11

補足

ご回答ありがとうございました。
申し訳ありません。確かに質問文が不足していました。
しかも、B3:B10というのも間違えです。
B3入力時は、F2へ画像挿入 B4入力時は、F9へ画像挿入といった形にしたいのです。
御指導宜しくお願い致します。

投稿日時 - 2009-05-29 22:40:50

あなたにオススメの質問