はじめまして。ご訪問ありがとうございます。
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(エクセル)
-
Excel 画像貼り付けのVBAについて
Excel(エクセル)
-
-
4
【VBA】写真の縦横比を変えずに貼り付ける
Visual Basic(VBA)
-
5
Excelのセル内に写真を手軽に挿入したい
Excel(エクセル)
-
6
【VBA】写真の貼り付けコードがうまく機能しません。
Visual Basic(VBA)
-
7
セルサイズに自動で合わせて画像を貼るマクロとカレンダーマクロでエラー表示・変数宣言とは。
Excel(エクセル)
-
8
エクセルマクロでダブルクリックして画像貼り付けでサイズ設定したいです。
Excel(エクセル)
-
9
エクセルで簡単に写真を挿入したい
Excel(エクセル)
-
10
エクセルマクロでシート内にある画像のみを選択する
Excel(エクセル)
-
11
マクロを実行すると画像がズレてしまいます
その他(Microsoft Office)
-
12
Excel VBAでセル内の画像を選択したい
Excel(エクセル)
-
13
ダブルクリックで貼り付けた画像からリンクのみ削除し、画像を残したい
Visual Basic(VBA)
-
14
VBAでエクセルのシート上の画像のリサイズと配置を行いたい
Excel(エクセル)
-
15
「Cancel = True」とはどういう意味でし
Word(ワード)
-
16
エクセルのVBAを使用し、工事写真台帳を作成しています。
Excel(エクセル)
-
17
エクセルVBAで縦向きの画像の挿入・回転
Excel(エクセル)
-
18
マクロで画像挿入→エラー「リンクされたイメージを表
Excel(エクセル)
-
19
任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい
Visual Basic(VBA)
-
20
EXCELのVBAで画像を選んだ順に貼り付ける方法
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
【EXCEL VBA】ダブルクリックで...
-
こんなことてしますか??
-
VBAのユーザーフォームのイメー...
-
C#で画像を他の画像に貼り付け...
-
UWSC 画像判定と条件分岐について
-
Excelで画像クリックのアテンシ...
-
jQuery . プログラミング 助け...
-
UWSCの色判定
-
gif 画像上の ボタンに リン...
-
OpenCVで出力を24bitのbmpにす...
-
UWSCでループ処理がうまくいき...
-
Excel ユーザーフォームで表示...
-
UWSC「画像が無い場合」
-
モーダルウィンドウ内で複数の...
-
【VBA】Excel2016で画像を一括...
-
HTMLで画像をポップアップで表...
-
Excelで画像URLを1つずつセル...
-
画像認識アルゴリズムについて
-
EXCEL VBA 複数のImageコントロ...
-
スマホでサイトの画像を長押し→...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
こんなことてしますか??
-
【EXCEL VBA】ダブルクリックで...
-
Excelで画像URLを1つずつセル...
-
EXCEL VBA 複数のImageコントロ...
-
HTMLで画像をポップアップで表...
-
背景画像の繰り返しについて
-
Excel ユーザーフォームで表示...
-
gif 画像上の ボタンに リン...
-
VBA シート毎に画像挿入
-
jQuery . プログラミング 助け...
-
VBAのユーザーフォームのイメー...
-
jqueryスライダーを2段でスライ...
-
ホームページバナーを(画像が...
-
「using Windows」でエラーが出る
-
スマホでサイトの画像を長押し→...
-
【WPF】画像の切り替え
-
PowerPoint VBA で画像の鮮明度...
-
画像のピクセルデータの取得
-
UWSCの色判定
-
UWSCを使った画像認証マク...
おすすめ情報