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で質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Excel(エクセル) 【マクロ】スクショ印刷がうまく動かない件 5 2022/12/06 17:37
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
- Excel(エクセル) Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて 2 2022/11/15 16:14
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- PowerPoint(パワーポイント) ExcelのVBAコードについて教えてください。 3 2022/05/25 14:32
- Visual Basic(VBA) QRコード作成マクロについて 3 2022/11/26 16:55
- Excel(エクセル) エクセルで同じ数字同士を自動で線で結ぶVBAを教えてください 6 2022/04/26 23:13
- Excel(エクセル) EXCELのグラフを画像(JPG形式)で保存、通常実行がうまく行かない。ステップインはうまく行く 3 2022/08/30 12:06
- Excel(エクセル) エクセルのマクロについて教えてください。 3 2023/02/07 14:47
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
【VBA】アクティブセルだけ背景...
-
VBAでの SendKeysの変数指定方法
-
vbaで指定したセルより下の行を...
-
エクセルでセルをクリックする...
-
マクロのデータ削除
-
Excelでプルダウンからフィルタ...
-
ExcelVBA コンボボックスに入力...
-
ダブルクリックでセルに色をつ...
-
A1から最下行までを選択するVBA
-
Excelマクロ セルを行頭に移動
-
IF関数で違う値もTRUEになる
-
エクセルで2箇所同時に字に丸囲...
-
マクロのif文
-
Excel VBA:フォーム←→セルのア...
-
マクロ:エクセルVBAでのワーク...
-
excel マクロでの特殊文字入力方法
-
Excel(M365) Vlookup/セル反転(...
-
Excel 範囲指定スクショについ...
-
エクセルで特定の文字列が入っ...
-
EXCEL VBA 文中の書式ごと複写...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
vbaで指定したセルより下の行を...
-
エクセルでセルをクリックする...
-
Excel VBA:フォーム←→セルのア...
-
VBAでの SendKeysの変数指定方法
-
Excelマクロ セルを行頭に移動
-
マクロのデータ削除
-
ダブルクリックでセルに色をつ...
-
IF関数で違う値もTRUEになる
-
ファイルサーバー上のexcelファ...
-
エクセルマクロで「セルのサイ...
-
Excel VBA で色付きのセルの値...
-
【VBA】アクティブセルだけ背景...
-
excel マクロでの特殊文字入力方法
-
セルをクリックしたら色を変え...
-
(エクセルVBA)セルを左クリッ...
-
【マクロ】1つのセルから結合...
-
ExcelVBA コンボボックスに入力...
-
Excelのマクロで選択している行...
-
VBA Rangeの足し算
-
エクセル:セルの色のコード番...
おすすめ情報