| |
お世話になります。
シートの結合セルにダブルクリックで画像を追加し、その画像をクリックすると削除できるマクロを作成しています。
一部頂いたコードを改造し画像の追加はできるのですが、削除のほうが「マクロを実行できません。このブックでマクロが使用できないか、また全てのマクロが無効になっている可能性があります。」とエラーメッセージが出て削除ができません。
削除用マクロ単独では動くのですが、onActionでだとエラーが出ます。
コードは下記になります。
−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
Option Explicit
'------------------------------------
'VBAProjectのExcelObjects内にあるシートをダブルクリックした際に表示される画面に下記文章をすべて貼り付けてください
'------------------------------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim s As String
Dim targetFlg As Boolean, picNo As Integer
Dim cells As Variant, cell As Variant
Dim tmp As String
Dim sheetNames As String
Dim picName As String
targetFlg = False
s = Target.Address
'シートに応じて下記を変更してください
'下の行の""で囲まれてる中に画像を挿入したいセル番号を記入（結合セルの場合選択したときに左上に出るセル番号を入力してください。）
cells = Array("A74", "F74", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "")
For Each cell In cells
tmp = Replace(s, "$", "")
tmp = Left(tmp, InStr(tmp, ":") - 1)
If cell = tmp Then
targetFlg = True
End If
Next
If targetFlg Then
Dim c As Range, cm As Range, sName As String
Application.ScreenUpdating = False
For Each c In Selection
Set cm = c.MergeArea
If c.Address = cm.Item(1).Address Then
sName = c.Address
If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub
With Selection
.ShapeRange.LockAspectRatio = False
.Left = cm.Left
.Top = cm.Top
.Height = cm.Height
.Width = cm.Width
.Name = tmp 'セルのアドレスを画像の名前に
End With
picName = Selection.Name
sheetNames = ThisWorkbook.ActiveSheet.Name
With ThisWorkbook.Worksheets(sheetNames).Shapes(tmp)
.OnAction = "delPic"
End With
End If
Next
Set cm = Nothing
Application.ScreenUpdating = True
End If
End Sub
'削除マクロ
−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
Sub delPic()
Dim Answer As Long
Dim sheetNames As String
Dim picName As String
Dim sName As String
Dim tmp As String
Dim s As String
s = Selection.Address
tmp = Replace(s, "$", "")
tmp = Left(tmp, InStr(tmp, ":") - 1)
sheetNames = ThisWorkbook.ActiveSheet.Name
Answer = MsgBox("画像が削除されます。よろしいですか？", vbOKCancel Or vbExclamation, "削除確認")
If Answer = vbOK Then
ThisWorkbook.Worksheets(sheetNames).Shapes(tmp).Delete
End If
End Sub
−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
何分初心者なもので稚拙なコードで申し訳ありませんが
ご教示お願いいたします。
|
|
Ask
- 11/8/26(金) 12:19 -
