![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?5a7ff87)
はじめまして。ご訪問ありがとうございます。
VBA初心者です。ただいまエクセルを使用し、添付画像の様な商品リストを作成しております。
【商品画像】の項目の列に効率良く画像を挿入したいと思い、下記のマクロを実施しました。
内容は画像を貼り付けたいB列のセル上でダブルクリックすると、ファイルが開き、選択した1枚の画像がセルの大きさに自動でリサイズされ貼り付けられる、とうものです。
※尚このマクロは「なまたまご情報局」さんのサイトを参考にさせていただき少し手を加えました。
http://rawegg.sakuraweb.com/excel-014/
そしてさらに、大量の画像に対応させる為に、指定フォルダの中にある画像を全てを一括で貼り付ける、という機能を追加したいと考えております。
貼り付ける先のセルは、選択中のセルを起点として、画像毎に下に下がって貼り付けて行くという感じです。
※「Programmer's EGG」さんのこのマクロのイメージです。
http://programlife.jugem.jp/?eid=48
今のマクロにどの様に追記すれば良いか教えていただきたく、どうぞよろしくお願いいたします。
------------------------
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myF As Variant
Dim mySp As Object
Dim myAD1 As String
Dim myAD2 As String
Dim myHH As Double
Dim myWW As Double
Dim myHH2 As Double
Dim myWW2 As Double
If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub
Cancel = True
'画像選択コマンド
myF = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If myF = False Then
MsgBox "画像を選んで下さい(終了します)"
Exit Sub
End If
'画像データの再構築
For Each mySp In ActiveSheet.Shapes
myAD1 = mySp.TopLeftCell.MergeArea.Address
myAD2 = Target.Address
If myAD1 = myAD2 Then mySp.Delete
Next
'リサイズして画像の貼り付け
Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=0, Height:=0)
mySp.ScaleHeight 1, msoTrue
mySp.ScaleWidth 1, msoTrue
'縮尺を変えずにリサイズ
If mySp.Width > Target.Width Then mySp.Width = Target.Width * 0.99
If mySp.Height > Target.Height Then mySp.Height = Target.Height * 0.99
'センター中心に配置
myHH2 = (Target.Height / 2) - (mySp.Height / 2)
myWW2 = (Target.Width / 2) - (mySp.Width / 2)
mySp.Top = Target.Top + myHH2
mySp.Left = Target.Left + myWW2
Set mySp = Nothing
End Sub
------------------------
![「【EXCEL VBA】ダブルクリックでセ」の質問画像](http://oshiete.xgoo.jp/_/bucket/oshietegoo/images/media/4/542611174_59ce729c33296/M.jpg)
No.1ベストアンサー
- 回答日時:
簡単に直すなら、こんな感じでしょうか。
ちなみに、「画像の選択」画面で複数のファイルを選択できるようにしただけなので、自力ですべてのファイルを選択する必要があります。「画像の選択」画面から「整理」-「すべて選択」で選択できるので、それほど手間ではないですが・・・。ちなみに、サブフォルダも選択されますが、処理的には無視されるので問題ないです。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myFs As Variant
Dim myF As Variant
Dim mySp As Object
Dim myAD1 As String
Dim myAD2 As String
Dim myHH As Double
Dim myWW As Double
Dim myHH2 As Double
Dim myWW2 As Double
If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub
Cancel = True
'画像選択コマンド
myFs = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , True)
If IsArray(myFs) = False Then
MsgBox "画像を選んで下さい(終了します)"
Exit Sub
End If
'画像データの再構築
For Each myF In myFs
For Each mySp In ActiveSheet.Shapes
myAD1 = mySp.TopLeftCell.MergeArea.Address
myAD2 = Target.Address
If myAD1 = myAD2 Then mySp.Delete
Next
'リサイズして画像の貼り付け
Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=0, Height:=0)
mySp.ScaleHeight 1, msoTrue
mySp.ScaleWidth 1, msoTrue
'縮尺を変えずにリサイズ
If mySp.Width > Target.Width Then mySp.Width = Target.Width * 0.99
If mySp.Height > Target.Height Then mySp.Height = Target.Height * 0.99
'センター中心に配置
myHH2 = (Target.Height / 2) - (mySp.Height / 2)
myWW2 = (Target.Width / 2) - (mySp.Width / 2)
mySp.Top = Target.Top + myHH2
mySp.Left = Target.Left + myWW2
Set mySp = Nothing
Set Target = Target.Offset(1)
Next myF
End Sub
ママチャリ様
はじめまして。この度はお忙しい中ご丁寧にご教示いただきまして、ありがとうございました!
m(_ _)m
教えていただきましたマクロの適用で、画像添付の作業時間が大幅に削減され感無量です!
今後もVBAを勉強して、便利なマクロが組める様に努力していきたいと思います。
また機会がございましたら、よろしくお願いいたします☆☆☆
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Excel(エクセル) Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて 2 2022/11/15 16:14
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
- Excel(エクセル) 【マクロ】スクショ印刷がうまく動かない件 5 2022/12/06 17:37
- Visual Basic(VBA) 【Excel VBA】自動メール送信の機能追加 5 2022/09/29 12:53
- Visual Basic(VBA) 【追加】ファイルを閉じてダイアログで保存した時だけ処理の実行をする 3 2022/03/23 15:43
- Visual Basic(VBA) excel vbaでvlooupの変数がわかりません。 7 2022/05/30 09:35
- Visual Basic(VBA) QRコード作成マクロについて 3 2022/11/26 16:55
- Excel(エクセル) VBAについて 3 2022/06/19 18:19
このQ&Aを見た人はこんなQ&Aも見ています
-
プロが教えるわが家の防犯対策術!
ホームセキュリティのプロが、家庭の防犯対策を真剣に考える 2組のご夫婦へ実際の防犯対策術をご紹介!どうすれば家と家族を守れるのかを教えます!
-
VBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)
Excel(エクセル)
-
【VBA】写真の縦横比を変えずに貼り付ける
Visual Basic(VBA)
-
Excel 画像貼り付けのVBAについて
Excel(エクセル)
-
-
4
セルをダブルクリックで、画像を選択、挿入したい時
Excel(エクセル)
-
5
【VBA】写真の貼り付けコードがうまく機能しません。
Visual Basic(VBA)
-
6
Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて
Excel(エクセル)
-
7
エクセルのVBAを使用し、工事写真台帳を作成しています。
Excel(エクセル)
-
8
セルサイズに自動で合わせて画像を貼るマクロとカレンダーマクロでエラー表示・変数宣言とは。
Excel(エクセル)
-
9
エクセルVBAで縦向きの画像の挿入・回転
Excel(エクセル)
-
10
マクロで画像挿入→エラー「リンクされたイメージを表
Excel(エクセル)
-
11
エクセルマクロでダブルクリックして画像貼り付けでサイズ設定したいです。
Excel(エクセル)
-
12
任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい
Visual Basic(VBA)
-
13
Excelのセル内に写真を手軽に挿入したい
Excel(エクセル)
-
14
EXCELのVBAで画像を選んだ順に貼り付ける方法
Excel(エクセル)
-
15
エクセルで簡単に写真を挿入したい
Excel(エクセル)
-
16
マクロを実行すると画像がズレてしまいます
その他(Microsoft Office)
-
17
VBAで選択した画像を貼り付けたい
Excel(エクセル)
-
18
VBAでエクセルのシート上の画像のリサイズと配置を行いたい
Excel(エクセル)
-
19
ダブルクリックで貼り付けた画像からリンクのみ削除し、画像を残したい
Visual Basic(VBA)
-
20
エクセル マクロ写真帳に一括で写真を張り付けたいです。
Visual Basic(VBA)
関連するカテゴリからQ&Aを探す
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
PHPの画像アップロード
-
uwscの画像認識の不具合だと思...
-
複数枚画像の合成
-
OpenCVを使った画像の切り抜き
-
UWSCを使って画像リンクをクリ...
-
画像のピクセルデータの取得
-
日本の白地図の画像に、都道府...
-
UWSC 画像認識で条件分岐
-
画像の一部だけが点滅する画像...
-
PowerPoint VBA で画像の鮮明度...
-
ImageMagickでgif画像の一部が...
-
C言語で画像処理
-
[ASP.NET]Imageコントロールで...
-
[FlashMX2004]サムネorリスト付...
-
MATLABのDICOM画像表示
-
jQueryで複数枚同時にスライダ...
-
jqueryスライダーを2段でスライ...
-
uwscの画像認識に失敗します。
-
ワードプレスで画像を何枚か横...
-
PCは表示されるがスマホでは画...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
ImageMagickでgif画像の一部が...
-
Pythonでgif画像が上手く作れない
-
こんなことてしますか??
-
【EXCEL VBA】ダブルクリックで...
-
Excel ユーザーフォームで表示...
-
「using Windows」でエラーが出る
-
背景画像の繰り返しについて
-
【WPF】画像の切り替え
-
uwcs のマクロで画像認識をして...
-
uwscの画像認識に失敗します。
-
vb.net 画像の透過について
-
EXCEL VBA 複数のImageコントロ...
-
UWSC「画像が無い場合」
-
gif 画像上の ボタンに リン...
-
VBAのユーザーフォームのイメー...
-
VBA シート毎に画像挿入
-
画像処理したBitmapをピクチャ...
-
UWSC 画像判定と条件分岐について
-
UWSC 画像認識で条件分岐
-
自作の地図をグーグルマップの...
おすすめ情報