
Excelマクロについては初心者です。
特定のフォルダにある画像をExcelシートに自動で貼り付けるマクロが必要になりました。
EXCELシートは添付画像のように単純な形式です。
A2セルに画像名入力
A1セルに画像を自動で貼り付け
条件:自動で貼り付けた画像は縦横比率でA1セルに強制的に収める
以下のマクロはA2セルに画像名を入力し、excelファイル開く直したときにA1セルにA2セルに入力されている名前の画像ファイルを貼り付けるという内容のマクロです。
マクロをいろいろいじってみて、画像貼り付け、中央揃えまでは上手くいったような気がしますが、
画像が小さく貼り付けてしまいまして(添付画像)、画像の大きさを調整に困っています。
ーーーーーーーーーーーーーーー
Private Sub Workbook_Open()
Dim shape As shape
Dim myRange As Range '画像を配置するセル範囲
Dim rX As Double, rY As Double
Dim objShape As shape
Set myRange = Range("A1")
Set targetRange = Range("A2")
With ActiveSheet.Pictures.Insert("C:\Users\ovner\Pictures\" & targetRange & ".jpg")
.Left = myRange.Left
.Top = myRange.Top
With .ShapeRange
.LockAspectRatio = msoTrue
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
rX = myRange.Width / .Width
rY = myRange.Height / .Height
If rX > rY Then
.Height = .Height * rY
.Width = .Width * rY
Else
.Height = .Height * rX
.Width = .Width * rX
End If
.Left = myRange + (myRange.Width - .Width) / 2
.Top = myRange.Top + (myRange.Height - .Height) / 2
End With
Application.ScreenUpdating = True
Cancel = True
End With
End Sub
ーーーーーーーーーーーーーーー
質問1:どすれば画像ファイルを縦横比率でA1セルに縦いっぱいまで拡大し、貼り付けすることができるでしょうか?
質問2:” ActiveSheet.Pictures.Insert("C:\Users\ovner\Pictures\" & targetRange & ".jpg") ”
このコードだと画像はリンクになると思いますが、
:” ActiveSheet.Shapes.AddPicture("C:\Users\ovner\Pictures\" & targetRange & ".jpg") ”
このように、リンクではない形式でも画像を自動貼り付けできるでしょう?
教えてください。よろしくお願いします。

A 回答 (2件)
- 最新から表示
- 回答順に表示
No.2
- 回答日時:
#1です
>質問1
縦横比率を変えず、高さがセルいっぱいになるようなサイズ変更でしょうか?
かも知れませんので With ActiveSheet.Shapes.AddPicture 部分を下記のようにします。幅をセル内に収める場合は、コメントアウトしている部分を実行コードにしてください。(いろいろ試してください)
With ActiveSheet.Shapes.AddPicture( _
Filename:=filePath & strFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, Top:=1, _
Width:=0, Height:=0)
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
.LockAspectRatio = msoTrue '比率を固定
'幅をセル内に収める(下3行を生かすと幅が超える場合幅に合わせます)
' If .Width > myRange.Width Then
' .Width = myRange.Width
' End If
If .Height > myRange.Height Then '高さをセル内に収める
.Height = myRange.Height
End If
.Left = myRange + (myRange.Width - .Width) / 2
.Top = myRange.Top + (myRange.Height - .Height) / 2
End With
No.1
- 回答日時:
こんにちは
>質問1
縦横比率を変えず、幅もしくは高さがセルのいずれかにいっぱいになるようなサイズ変更でしょうか?
コードを見ると縦横共にいっぱいに成るようになっているようですが
>質問2
>ActiveSheet.Shapes.AddPicture("C:\Users\ovner\Pictures\" & targetRange & ".jpg") ”
このように、リンクではない形式でも画像を自動貼り付けできるでしょう?
はい出来ます。
Workbook_OpenやCancel = Trueを見ると、まだまだ問題が出て来そうですが、セルの関係から、複数取得なども考えられているのでしょうか?
下記にご質問のコードで標準モジュールに書き、ボタンなどから実行するサンプルを書きます。一応Dirで取得時のエラー回避を入れて置きます。
質問1については、ご質問コードそのままなのでせるの縦横いっぱいに表示されると思います。取敢えずの参考にしてください。
Private Sub test()
Dim shape As shape
Dim myRange As Range '画像を配置するセル範囲
Dim targetRange As Range
Dim filePath As String, strFileName As String
Dim rX As Double, rY As Double
Dim objShape As shape
Set myRange = Range("A1")
Set targetRange = Range("A2")
filePath = "C:\Users\ovner\Pictures\"
strFileName = Dir(filePath & targetRange & ".jpg")
If strFileName = "" Then MsgBox ("対象ファイルはありません"): Exit Sub
With ActiveSheet.Shapes.AddPicture( _
Filename:=filePath & strFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, Top:=1, _
Width:=0, Height:=0)
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
rX = myRange.Width / .Width
rY = myRange.Height / .Height
If rX > rY Then
.Height = .Height * rY
.Width = .Width * rY
Else
.Height = .Height * rX
.Width = .Width * rX
End If
.Left = myRange + (myRange.Width - .Width) / 2
.Top = myRange.Top + (myRange.Height - .Height) / 2
End With
End Sub
Qchan1962様 ありがとうございました。
質問1の件ですが、おっしゃった通り 縦横比率を変えず、幅もしくは高さがセルのいずれかにいっぱいになるようにしたいでした、私も昨日いろいろ試してみました。訳が分からないですが、「.LockAspectRatio = msotrue」 部分のtrue をfalseに変えるか、この行を削除で質問1の目的が達成しました。
質問2ですが、ボタン式も考えたんですが、200ぐらいのexcelファイルにすべてボタン作るのはどうかなと思ってやめました。
With ActiveSheet.Shapes.AddPicture( _
Filename:=filePath & strFileName, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, Top:=1, _
Width:=0, Height:=0)
この部分を参考にさせていただきました。ありがとうございました。
Set myRange = Range("A1")
Set targetRange = Range("A2")
Set objShape = ActiveSheet.Shapes.AddPicture( _
Filename:="C:\Users\ovner\Pictures\" & targetRange & ".jpg", _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, _
Top:=1, _
Width:=0, _
Height:=0)
このように変更することで目的を達成しまた。
毎回エクセルファイルを開いたときに写真が貼り付けられファイルサイズが大きくなるので、ファイルを閉じたときに画像をいったん削除するようにマクロを追加しました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
今、見られている記事はコレ!
-
弁護士が解説!あなたの声を行政に届ける「パブリックコメント」制度のすべて
社会に対する意見や不満、疑問。それを発信する場所は、SNSやブログ、そしてニュースサイトのコメント欄など多岐にわたる。教えて!gooでも「ヤフコメ民について」というタイトルのトピックがあり、この投稿の通り、...
-
弁護士が語る「合法と違法を分けるオンラインカジノのシンプルな線引き」
「お金を賭けたら違法です」ーーこう答えたのは富士見坂法律事務所の井上義之弁護士。オンラインカジノが違法となるかどうかの基準は、このように非常にシンプルである。しかし2025年にはいって、違法賭博事件が相次...
-
釣りと密漁の違いは?知らなかったでは済まされない?事前にできることは?
知らなかったでは済まされないのが法律の世界であるが、全てを知ってから何かをするには少々手間がかかるし、最悪始めることすらできずに終わってしまうこともあり得る。教えてgooでも「釣りと密漁の境目はどこです...
-
カスハラとクレームの違いは?カスハラの法的責任は?企業がとるべき対応は?
東京都が、客からの迷惑行為などを称した「カスタマーハラスメント」、いわゆる「カスハラ」の防止を目的とした条例を、全国で初めて成立させた。条例に罰則はなく、2025年4月1日から施行される。 この動きは自治体...
-
なぜ批判コメントをするの?その心理と向き合い方をカウンセラーにきいた!
今や生活に必要不可欠となったインターネット。手軽に情報を得られるだけでなく、ネットを介したコミュニケーションも一般的となった。それと同時に顕在化しているのが、他者に対する辛らつな意見だ。ネットニュース...
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
セルをクリックしたら色を変え...
-
vbaで指定したセルより下の行を...
-
マクロのデータ削除
-
エクセルでセルをクリックする...
-
Excelマクロでウェブ上から現在...
-
IF関数で違う値もTRUEになる
-
Excelで指定のセル上に図を配置...
-
EXCEL(VBA) セルをクリックし...
-
エクセルマクロで「セルのサイ...
-
Excel VBA:フォーム←→セルのア...
-
Excel VBA で色付きのセルの値...
-
【EXCEL-VBA】特定の値の入った...
-
Excel UserForm の表示位置
-
ExcelVBAでテキストルーレット...
-
【VBA】写真の貼り付けコードが...
-
Worksheets メソッドは失敗しま...
-
マクロの「SaveAs」でエラーが...
-
【マクロ】実行時エラー '424':...
-
ExcelVBA修正のお願い
-
excel 小さすぎて見えないセル...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
vbaで指定したセルより下の行を...
-
エクセルでセルをクリックする...
-
セルをクリックしたら色を変え...
-
Excelマクロ セルを行頭に移動
-
VBAでの SendKeysの変数指定方法
-
Excel VBA:フォーム←→セルのア...
-
エクセルマクロで「セルのサイ...
-
(エクセルVBA)セルを左クリッ...
-
VBA Rangeの足し算
-
【EXCEL-VBA】特定の値の入った...
-
Excel VBA で色付きのセルの値...
-
マクロのデータ削除
-
ExcelVBA コンボボックスに入力...
-
IF関数で違う値もTRUEになる
-
【マクロ】1つのセルから結合...
-
Excelで数値の変化をカウントし...
-
ファイルサーバー上のexcelファ...
-
ロックされていないセル内をクリア
-
VBA ボタンをセルの右側に合わ...
-
excel マクロでの特殊文字入力方法
おすすめ情報