はじめまして。ご訪問ありがとうございます。
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も見ています
-
プロが教えるわが家の防犯対策術!
ホームセキュリティのプロが、家庭の防犯対策を真剣に考える 2組のご夫婦へ実際の防犯対策術をご紹介!どうすれば家と家族を守れるのかを教えます!
-
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
マクロを実行すると画像がズレてしまいます
その他(Microsoft Office)
-
11
Excel VBAでセル内の画像を選択したい
Excel(エクセル)
-
12
VBAでエクセルのシート上の画像のリサイズと配置を行いたい
Excel(エクセル)
-
13
エクセルマクロでシート内にある画像のみを選択する
Excel(エクセル)
-
14
「Cancel = True」とはどういう意味でし
Word(ワード)
-
15
マクロで画像挿入→エラー「リンクされたイメージを表
Excel(エクセル)
-
16
任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい
Visual Basic(VBA)
-
17
エクセルのVBAを使用し、工事写真台帳を作成しています。
Excel(エクセル)
-
18
ダブルクリックで貼り付けた画像からリンクのみ削除し、画像を残したい
Visual Basic(VBA)
-
19
エクセルVBAで縦向きの画像の挿入・回転
Excel(エクセル)
-
20
Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Pythonでgif画像が上手く作れない
-
EXCEL VBA 複数のImageコントロ...
-
UWSCの色判定
-
イメージマップでマウスオーバ...
-
jqueryスライダーを2段でスライ...
-
こんなことてしますか??
-
uwscについて質問です。
-
Excel ユーザーフォームで表示...
-
画像の2次元フーリエ変換の結...
-
【EXCEL VBA】ダブルクリックで...
-
Pythonのプログラム初心者の問題
-
自作の地図をグーグルマップの...
-
VBAのユーザーフォームのイメー...
-
UWSCの画像認識と条件分岐につ...
-
画像の一部だけが点滅する画像...
-
ヒストグラム類似度による画像...
-
Leafletで画像をon、offさせる...
-
gif画像が壊れて読み込まない
-
UWSCについて
-
PowerPoint VBA で画像の鮮明度...
マンスリーランキングこのカテゴリの人気マンスリー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を使った画像認証マク...
おすすめ情報