VBA 図の選択

質問

VBAについて質問です。 結合セルに画像を貼付けるとすべての画像が変更してしまいます。
ご教示をお願いいたします。

目的：結合セルに貼付る図だけを変更したい。

症状：下記のプログラムを実行すると、シート上のすべての図が変更してしまいます。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$D$5:$U$18" Then Call 図の挿入 '#1
　　'省略
If Target.Address = "$X$5:$AO$18" Then Call 図の挿入 '#12
End Sub

Sub 図の挿入()
Application.Dialogs(xlDialogInsertPicture).Show
Call 図の貼付
End Sub

Sub 図の貼付()
Dim sp As Shape

For Each sp In ActiveSheet.Shapes
If sp.Type = msoPicture Then
sp.LockAspectRatio = msoTrue
sp.Top = sp.TopLeftCell.Top
sp.Left = sp.TopLeftCell.Left
If sp.Width * ActiveCell.MergeArea.Height / sp.Height < ActiveCell.MergeArea.Width Then
sp.Height = ActiveCell.MergeArea.Height '--高さ基準
Else
sp.Width = ActiveCell.MergeArea.Width '--幅基準
End If
End If
Next
End Sub

回答No.3

mitarashi · ベストアンサー

#1,2です。
全列幅を18pixelに変更したシートに、7200×5200の画像を読みこんでみると現象が再現されました。
安直な対策案ですが、列幅を狭くしてない作業用シートに一旦読みこんで、サイズを縮小した後、
目的のシートにカット＆ペーストし、更に目的のサイズに変更します。ペーストの際に、JPEG形式で貼り付けると、元に戻せない代わりにファイルサイズが小さくなります。

Private Sub insertPic(myRange As Range)
Dim myPic As Picture
Dim myRatio As Double

Application.ScreenUpdating = False
'列幅を狭くしてない作業用シートを指定
Sheets(2).Activate
If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub
Set myPic = Selection
myPic.Width = myPic.Width / 10 '適当なサイズに縮小
myPic.Height = myPic.Height / 10
myPic.Cut
Me.Activate
myRange.Activate
Me.Paste
'ファイルサイズを小さくしたければ代わりに下記を採用してください
' Me.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
Set myPic = Selection
myRatio = myPic.Width / myPic.Height
If myPic.Width * myRange.Height / myPic.Height < myRange.Width Then
myPic.Height = myRange.Height
myPic.Width = myRange.Height * myRatio
Else
myPic.Width = myRange.Width
myPic.Height = myRange.Width / myRatio
End If
Application.ScreenUpdating = True
End Sub

なお、ご質問の追加の件ですが、一応動くようになって判明した問題点なので許容範囲内かと思いますが、当方夜しか対応できませんので、質問を別立てにしていれば他の方からの回答も期待できるかもしれません。

回答No.2

mitarashi

#1です。
とりあえず何もしないで抜けるなら、
Application.Dialogs(xlDialogInsertPicture).Show
に代えて
If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub
として下さい。

お礼

mitarasiさん、回答ありがとうございます。
if =false にはこういう使い方ができるのですね。
VBA初心者の私には新しい発見です、本当にありがとうございます。

補足

回答ありがとうございます。
問題の「エラー処理」は解決いたしました。

しかし、新たな問題がありますので質問いたします。

大きすぎる図（シートより大きな写真）を貼り付けた場合、
図の縦横比が、原型のサイズの縦横比と違ってしまいます。

目的：指定したセルのサイズの中に、図の原型の縦横比で貼り付ける。

症状：図をシートに挿入した段階で、図の縦横比が変更している。それは、行の数はIVまでしかないので、図の幅がシートの行の幅まで小さくなってしまいます。
　※例　図の高さ100％幅80％

新たに質問すべきか迷いましたが、この場で質問いたしました。
今回が初めての質問となります、今回の質問のマナーについても、ご意見を伺えればうれしいです。

回答No.1

mitarashi

VBA歴はそこそこ長いつもりですが、もっぱらPictures.Insertを使っていて、Application.Dialogs(xlDialogInsertPicture).Showは使った事がありませんでした。
試しにやってみました。なお当方xl2000です。
元のコードは沢山の画像のなかから該当するものを見つけて処理しようとして苦労しているので、貼り付けた画像をObject変数で受けてから操作すると自由が利くと考えたのですが、
画像貼付後にSelectionをShape型にsetしようとすると型違いのエラーになってしまうので、やむを得ずPicture型で受けたところ、元々のコードとはかけ離れてしまいましたが、ご参考まで。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$D$5:$U$18" Then Call insertPic(Target)
End Sub

Private Sub insertPic(myRange As Range)
Dim myPic As Picture

Application.Dialogs(xlDialogInsertPicture).Show
Set myPic = Selection
Call pastePic(myPic, myRange)
End Sub

Sub pastePic(sp As Picture, myRange As Range)
Dim myRatio As Double

sp.Top = myRange.Top
sp.Left = myRange.Left
myRatio = sp.Width / sp.Height
If sp.Width * myRange.Height / sp.Height < myRange.Width Then
sp.Height = myRange.Height '--高さ基準
sp.Width = myRange.Height * myRatio
Else
sp.Width = myRange.Width '--幅基準
sp.Height = myRange.Width / myRatio
End If
End Sub

補足

回答ありがとうございます。
問題の「すべての図が変更してしまう」は解決しました。

しかし、「図の挿入」ダイアログを開き、図を選択せずに閉じると、
「実行時エラー　'13':　型が一致しません。」
「Set myPic = Selection」が黄色に塗りつぶし
が出て、デバッグになってしまいます。

どのようなエラー処理の方法があるのか、ご教示いただけると助かります。