ここから本文です

エクセルで特定のセルをダブルクリックしたとき、画像を貼り付けるマクロを作成し...

sir********さん

2016/7/816:23:07

エクセルで特定のセルをダブルクリックしたとき、画像を貼り付けるマクロを作成したく、ネットで探しながら作ったのですが、貼り付ける画像を選択せずにキャンセルするとエラーでエクセルが強制終了してしまいます。

画像を選択した場合はエラーは発生せず、キャンセルしたときのみ発生してしまいます。
どのように修整すれば改善できますでしょうか。
また、原因は何かわかりますでしょうか。

下記がその内容です。

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myPic As Variant
Dim myShp As Shape, Shp As Shape
Dim myRange1 As Range, myRange2 As Range
Dim myRange3 As Range, myRange4 As Range
Dim myRange5 As Range, myRange6 As Range
Dim myRange7 As Range, myRange8 As Range
Dim myRange9 As Range, myRange10 As Range
Dim myRange11 As Range, myRange12 As Range
Dim myRange13 As Range, myRange14 As Range
Dim myRange15 As Range, myRange16 As Range
Dim myRange As Range

Set myRange1 = Range("B11:B20"): Set myRange2 = Range("B22:B31")
Set myRange3 = Range("B33:B42"): Set myRange4 = Range("B44:B53")
Set myRange5 = Range("B56:B65"): Set myRange6 = Range("B67:B76")
Set myRange7 = Range("B78:B87"): Set myRange8 = Range("B89:B98")
Set myRange9 = Range("B100:B109"): Set myRange10 = Range("M11:M20")
Set myRange11 = Range("M22:M31"): Set myRange12 = Range("M33:M42")
Set myRange13 = Range("M44:M53"): Set myRange14 = Range("M56:M65")
Set myRange15 = Range("M67:M76"): Set myRange16 = Range("M78:M87")


Set myRange = Union(myRange1, myRange2, myRange3, myRange4, myRange5, myRange6, myRange7, myRange8, myRange9, myRange10, myRange11, myRange12, myRange13, myRange14, myRange15, myRange16)

If Intersect(Target, myRange) Is Nothing Then Exit Sub
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.mpeg;*.mpg;*.png")
If VarType(myPic) = vbBoolean Then Exit Sub


Application.ScreenUpdating = False

If Not Intersect(Target, myRange1) Is Nothing Then
myRange1.Select
ElseIf Not Intersect(Target, myRange2) Is Nothing Then
myRange2.Select
ElseIf Not Intersect(Target, myRange3) Is Nothing Then
myRange3.Select
ElseIf Not Intersect(Target, myRange4) Is Nothing Then
myRange4.Select
ElseIf Not Intersect(Target, myRange5) Is Nothing Then
myRange5.Select
ElseIf Not Intersect(Target, myRange6) Is Nothing Then
myRange6.Select
ElseIf Not Intersect(Target, myRange7) Is Nothing Then
myRange7.Select
ElseIf Not Intersect(Target, myRange8) Is Nothing Then
myRange8.Select
ElseIf Not Intersect(Target, myRange9) Is Nothing Then
myRange9.Select
ElseIf Not Intersect(Target, myRange10) Is Nothing Then
myRange10.Select
ElseIf Not Intersect(Target, myRange11) Is Nothing Then
myRange11.Select
ElseIf Not Intersect(Target, myRange12) Is Nothing Then
myRange12.Select
ElseIf Not Intersect(Target, myRange13) Is Nothing Then
myRange13.Select
ElseIf Not Intersect(Target, myRange14) Is Nothing Then
myRange14.Select
ElseIf Not Intersect(Target, myRange15) Is Nothing Then
myRange15.Select
ElseIf Not Intersect(Target, myRange16) Is Nothing Then
myRange16.Select
End If

For Each myShp In Me.Shapes
If myShp.Name = "画像" & Selection.Address Then
myShp.Delete
End If
Next

Set Shp = Me.Shapes.AddPicture(Filename:=myPic, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=0, _
Height:=0)

With Shp
.ScaleHeight 1!, msoTrue
.ScaleWidth 1!, msoTrue
.LockAspectRatio = msoFalse
.Top = Selection.Top
.Left = Selection.Left
.Height = Selection.Height
.Width = Selection.Width
.Rotation = 0
.Name = "画像" & Selection.Address
End With

Set Shp = Nothing: Set myRange = Nothing
Set myRange1 = Nothing: Set myRange2 = Nothing
Set myRange3 = Nothing: Set myRange4 = Nothing
Set myRange5 = Nothing: Set myRange6 = Nothing
Set myRange7 = Nothing: Set myRange8 = Nothing
Set myRange9 = Nothing: Set myRange10 = Nothing
Set myRange11 = Nothing: Set myRange12 = Nothing
Set myRange13 = Nothing: Set myRange14 = Nothing
Set myRange15 = Nothing: Set myRange16 = Nothing


Application.ScreenUpdating = True

Cancel = True

End Sub

閲覧数:
88
回答数:
2
お礼:
100枚

違反報告

ベストアンサーに選ばれた回答

2016/7/820:47:20

私のPCで試しましたがキャンセルしてもエラーは出ませんでした。

参考までに多少作り直したコードを提示しておきます。


Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myAreas As Variant, myArea As Variant
Dim myRange As Range
Dim myPic As Variant
Dim myShp As Shape, Shp As Shape
myAreas = Array( _
"B11:B20", "B22:B31", "B33:B42", "B44:B53", _
"B56:B65", "B67:B76", "B78:B87", "B89:B98", _
"B100:B109", "M11:M20", "M22:M31", "M33:M42", _
"M44:M53", "M56:M65", "M67:M76", "M78:M87" _
)
For Each myArea In myAreas
Set myRange = Range(myArea)
If Not Intersect(Target, myRange) Is Nothing Then
myRange.Select
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.mpeg;*.mpg;*.png")
If VarType(myPic) <> vbBoolean Then
Application.ScreenUpdating = False
For Each myShp In Me.Shapes
If myShp.Name = "画像" & Selection.Address Then
myShp.Delete
End If
Next

Set Shp = Me.Shapes.AddPicture(Filename:=myPic, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=0, _
Height:=0)

With Shp
.ScaleHeight 1!, msoTrue
.ScaleWidth 1!, msoTrue
.LockAspectRatio = msoFalse
.Top = Selection.Top
.Left = Selection.Left
.Height = Selection.Height
.Width = Selection.Width
.Rotation = 0
.Name = "画像" & Selection.Address
End With
Application.ScreenUpdating = True
End If

Cancel = True
Exit Sub
End If
Next
End Sub

質問した人からのコメント

2016/7/12 15:51:53

ありがとうございました!
自作のものよりスッキリした上にエラーも出なくなりました!

ベストアンサー以外の回答

1〜1件/1件中

kak********さん

2016/7/820:34:02

たぶん、

'If VarType(myPic) = vbBoolean Then Exit Sub '修正箇所

If myPic = False Then Exit Sub

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる