[[20170907161144]]　『「エクセル2010　ＶＢＡ　画像挿入　」[しん]　に』（しょう。）　ページの最後に飛ぶ

『「エクセル2010　ＶＢＡ　画像挿入　」[しん]　について』（しょう。）

投稿
[[20150419120616]] 『エクセル2010　ＶＢＡ　画像挿入　』（しん）　
について...

上記の掲示板を見て、画像挿入のVBAを作成致しました。
ありがとうございました。

今作成しているのが、
１つのエクセルに対し、ワークシートが５つほどあり、
各シート毎に式を入力しています。

1シート目だけは画像を挿入してもエラーが出ないのですが、
2シート目からは画像を挿入しようとすると、
「実行時エラー'1004':
　アプリケーション定義またはオブジェクト定義のエラーです」と表示され、
VBA上の「myAD1 = mySp.TopLeftCell.MergeArea.Address」が黄色く塗りつぶされています。

でも、そのエラーは出たり出なかったりしています。

ネットやこちらでも検索してみましたが、
原因が不明の為、投稿させていただきました。

＜--記載している式--＞
Option Explicit

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
    Dim myF As Variant
    Dim mySp As Object
    Dim myAD1 As String
    Dim myAD2 As String
    Dim myHH As Double
    Dim myWW As Double
    Dim myHH2 As Double
    Dim myWW2 As Double

    If Intersect(Range("B4,V4,B22,V22,B40,V40,B62,V62,B81,V81.B99,V99,B117,V117,B135,V135,B158,V158,B176,V176,B194,V194,B212,V212"), Target) Is Nothing Then Exit Sub

    Cancel = True
    '===============画像選択
    myF = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
    If myF = False Then
        MsgBox "画像を選択してください(終了)"
        Exit Sub
    End If
    '===============画像の掃除
    For Each mySp In ActiveSheet.Shapes
        myAD1 = mySp.TopLeftCell.MergeArea.Address
        myAD2 = Target.Address
        If myAD1 = myAD2 Then mySp.Delete
    Next
    '===============画像の貼り付け
    Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
        SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
        Width:=0, Height:=0)    '★　とりあえず　縦横０で。
    mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す
    mySp.ScaleWidth 1, msoTrue  '★元のサイズに戻す
    '===============タテヨコの縮尺を保持
    If mySp.Width > Target.Width Then mySp.Width = Target.Width
    If mySp.Height > Target.Height Then mySp.Height = Target.Height
    '===============中央へ調整
    myHH2 = (Target.Height / 2) - (mySp.Height / 2)
    myWW2 = (Target.Width / 2) - (mySp.Width / 2)
    mySp.Top = Target.Top + myHH2
    mySp.Left = Target.Left + myWW2
    Set mySp = Nothing
 End Sub

＜--式ここまで--＞

ご存知の方がいらっしゃいましたら、
教えていただけますと幸いです。

宜しくお願い致します。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

普通に動作するコードのようですね。そうなると、怪しいのは、同じセルなら画像を削除して…、とかやっているので、表示更新の隙がないのが問題でしょうか。
エラーで止まった行の前に、DoEventsを2,3行追加してみてください。これで再現しなくなるようならば、無条件でDoEventsするのではなく、画像削除した場合だけDoEventsするように変えてみてください。
（???） 2017/09/07(木) 17:15

???さん、ありがとうございます☆

エラーも出る時と出ない時があったのですが、
今朝、エラーが出た時に「DoEvents」を下記の場所に入れてみました。

　　　　DoEvents
　　　　myAD1 = mySp.TopLeftCell.MergeArea.Address

        DoEvents
　　　　myAD2 = Target.Address

今の所、エラーはなくなっています！

ただ、画像削除した場合だけに「DoEvents」を入れるにはどのように記述したらいいか教えていただいてもよろしいでしょうか。

（しょう。） 2017/09/08(金) 10:35

同じセルなら元を削除するのは、以下の1行ですよね。

        If myAD1 = myAD2 Then mySp.Delete

これを、以下のようにするだけです。元々、End If を省略して1行で書いてしまうことは、ネスティングが判りにくくなるので、お薦めできない書き方です。必ず End If まで書く事を心がけると良いでしょう。

        If myAD1 = myAD2 Then
            mySp.Delete
            DoEvents
        End If
（???） 2017/09/08(金) 10:57

???さん、早々のご返信ありがとうございました。

式の書き方につきましてもアドバイスありがとうございます。
今後癖付けをしておきます。。。
その前に式の書き方を勉強しなくてはですね！

あと、式を上記のように記入してみましたが、
今度は違うセルで発生しました。
でも、保存してまた開いて画像を選択するとうまくいきました。

ちょっと原因不明すぎますが、
エラーが出る回数もほぼゼロなので、これで進めます。

お忙しい中教えていただきありがとうございました☆
（しょう。） 2017/09/08(金) 13:09

DoEvents 1回だと不十分で、2,3回入れると安定する場合もあるので、再発するようなら試してみてください。または、他にも自マクロ外のオブジェクトを操作している箇所があれば、その直後にも入れてみる、とか。
（???） 2017/09/08(金) 13:32

？？？さん、お返事が遅くなってすみません(>_<)

あの後も数回出る時と出ない時があったので、
前後だったりと入れてみると、エラーもなくなりました。

ありがとうございました☆
（しょう。） 2017/09/15(金) 13:57

コメント返信：

[ 一覧(最新更新順) ]

[[20170907161144]] 『「エクセル2010 ＶＢＡ 画像挿入 」[しん] に』（しょう。） ページの最後に飛ぶ

[[20170907161144]]　『「エクセル2010　ＶＢＡ　画像挿入　」[しん]　に』（しょう。）　ページの最後に飛ぶ