はじめまして。ご訪問ありがとうございます。
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
------------------------
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も見ています
-
プロが教える店舗&オフィスのセキュリティ対策術
中・小規模の店舗やオフィスのセキュリティセキュリティ対策について、プロにどう対策すべきか 何を注意すべきかを教えていただきました!
-
VBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)
Excel(エクセル)
-
セルをダブルクリックで、画像を選択、挿入したい時
Excel(エクセル)
-
【VBA】写真の縦横比を変えずに貼り付ける
Visual Basic(VBA)
-
-
4
Excel 画像貼り付けのVBAについて
Excel(エクセル)
-
5
【VBA】写真の貼り付けコードがうまく機能しません。
Visual Basic(VBA)
-
6
Excelのセル内に写真を手軽に挿入したい
Excel(エクセル)
-
7
エクセルで簡単に写真を挿入したい
Excel(エクセル)
-
8
エクセルマクロでダブルクリックして画像貼り付けでサイズ設定したいです。
Excel(エクセル)
-
9
セルサイズに自動で合わせて画像を貼るマクロとカレンダーマクロでエラー表示・変数宣言とは。
Excel(エクセル)
-
10
エクセルのVBAを使用し、工事写真台帳を作成しています。
Excel(エクセル)
-
11
VBAでエクセルのシート上の画像のリサイズと配置を行いたい
Excel(エクセル)
-
12
エクセルマクロでシート内にある画像のみを選択する
Excel(エクセル)
-
13
マクロを実行すると画像がズレてしまいます
その他(Microsoft Office)
-
14
Excel VBAでセル内の画像を選択したい
Excel(エクセル)
-
15
任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい
Visual Basic(VBA)
-
16
EXCELのVBAで画像を選んだ順に貼り付ける方法
Excel(エクセル)
-
17
VBAで選択した画像を貼り付けたい
Excel(エクセル)
-
18
ダブルクリックで貼り付けた画像からリンクのみ削除し、画像を残したい
Visual Basic(VBA)
-
19
エクセルVBAで縦向きの画像の挿入・回転
Excel(エクセル)
-
20
Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
【EXCEL VBA】ダブルクリックで...
-
ImageMagickでgif画像の一部が...
-
Pythonでgif画像が上手く作れない
-
「using Windows」でエラーが出る
-
Excel ユーザーフォームで表示...
-
svgクリップパスの応用コーディ...
-
マウスオーバーで画像の一部を...
-
Jimdoで画像をポップアップ表示...
-
生成AI画像について
-
【WPF】画像の切り替え
-
画像ファイルのストリーミング取得
-
画像の比較
-
8bit(256色)グレースケール画...
-
jqueryスライダーを2段でスライ...
-
ヒストグラム類似度による画像...
-
画像処理したBitmapをピクチャ...
-
こんなことてしますか??
-
モーダルウィンドウ内で複数の...
-
HTMLでサイトの模写をしていま...
-
MATLABのDICOM画像表示
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
【EXCEL VBA】ダブルクリックで...
-
こんなことてしますか??
-
Pythonでgif画像が上手く作れない
-
Excel ユーザーフォームで表示...
-
VBA シート毎に画像挿入
-
生成AI画像について
-
EXCEL VBA 複数のImageコントロ...
-
HTMLで画像をポップアップで表...
-
UWSCの色判定
-
UWSC 画像判定と条件分岐について
-
jQuery . プログラミング 助け...
-
VBAのユーザーフォームのイメー...
-
jqueryスライダーを2段でスライ...
-
vb.net 画像の透過について
-
【WPF】画像の切り替え
-
背景画像の繰り返しについて
-
「using Windows」でエラーが出る
-
画像処理したBitmapをピクチャ...
-
スマホでサイトの画像を長押し→...
-
UWSC 画像認識で条件分岐
おすすめ情報