vbaエラー　Pasteプロパティ　原因と対策を教えて下さい。

前提・実現したいこと

vbaのエラーで、原因と対策を教えて下さい。2件あります。

2件とも、Pasteプロパティで原因不明のエラーが出ます。
10回に1～3回程度で、上手く完了する場合の方が多いですが、同じ状況で実行してもたまにエラーが出ます。

1件目は、フォルダ内にある品番毎のフォルダから、合致する品番フォルダ内に格納されているjpeg画像を表示させるマクロです。
2件目は、1件目で表示させたjpeg画像を圧縮するマクロです。

いずれも、1度実行してエラーが出ても、再度実行すれば上手くいったりはしますが、1件目のvbaを2回起動するとが画像が
倍になってしまうので、そもそもエラーが出ないようにしたいです。
難しければ、画像を削除するマクロも用意しようかとは考えています。

他にも、エラーが出ても成功するまで繰り返す、とかも考えましたが、そもそものエラーに対して原因を把握して対処できるのが
望ましいです。

宜しくお願い致します。

発生している問題・エラーメッセージ

1件目のvbaエラー(2つのうちいずれかでエラーになります。)
　1つ目
　　実行時エラー'1004':
　　データを貼り付けできません。

　2つ目(1件目のエラーはこちらの方が発生確率が高いです。)
　　実行時エラー'1004':
　　PictureクラスのPasteプロパティを取得できません。


2件目のvbaエラー
　　実行時エラー'1004':
　　データを貼り付けできません

該当のソースコード

■■■1件目のソースコード■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
　Sub 画像一括表示()
　Dim ファイル As String, xErr As Long
　Dim 最終行 As Long, 行 As Long

　最終行 = Range("C" & Rows.Count).End(xlUp).Row

　For 行 = 13 To 最終行 Step 6
    　If Cells(行, 3) <> "" Then                                                              '商品コードが入力されていたら
        　ファイル = "【ここでフォルダパスを入力しています。内容は割愛します。】" & Cells(行, 3).Value & ".jpg"
        
        Cells(行, 1).Select
        Cells(行, 3).Font.ColorIndex = 0
        On Error Resume Next                                                                'エラーが起きても処理を続行
        ActiveSheet.Pictures.Insert(ファイル).Select
        xErr = Err.Number                                                                      'エラー番号取得
        On Error GoTo 0                                                                          'エラー処理解除
        If xErr = 0 Then                                                                          'エラーが発生していなければ
        With Selection
            .ShapeRange.LockAspectRatio = msoTrue
            .ShapeRange.Height = 195.96
            .Copy　　　　　　　　　　　　　　　　　　　　'▼▼▼←1件目　1つ目のエラー箇所です。▼▼▼
            .Delete
        End With
        ActiveSheet.Pictures.Paste.Select　　　　　   '▼▼▼←1件目　2つ目のエラー箇所です。▼▼▼
        'DoEvents　【修正メモ】たぶんいらないはず
        With Selection
        .ShapeRange.name = Cells(行, 3).Value
        .ShapeRange.IncrementTop 1.0714173228 * 2
        End With
        Else
        Cells(行, 3).Font.ColorIndex = 0
        End If
        Application.Wait [Now()] + 25 / 86400000
    End If
　Next 行
　Range("C2:H2").Select

　End Sub


■■■2件目のソースコード■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
　Sub 画像圧縮_実行()

　Application.ScreenUpdating = False

　Dim sp As Shape
　Dim l As Double
　Dim t As Double
　Dim n

　For Each sp In ActiveSheet.Shapes
    If sp.Type = msoPicture Then
        l = sp.Left
        t = sp.Top
        n = sp.name
        sp.Select
        Selection.Cut
        ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False　　　'▼▼▼←2件目のエラー箇所です。▼▼▼
        'DoEvents　【修正メモ】たぶんいらないはず
        With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
            .Left = l
            .Top = t
            .name = n
        End With
    End If
    Application.Wait [Now()] + 75 / 86400000
　Next

　Application.ScreenUpdating = True
　MsgBox "画像圧縮が完了しました。", vbOKOnly
　End Sub

試したこと

処理の合間に待機時間やエラー箇所直後にDoeventsを挟んでも直りませんでした。

補足情報（FW/ツールのバージョンなど）

行動規範の内容に同意します

回答1件

ベストアンサー

今、出先からスマホで回答しているので、実際に試したり詳細に説明したりできないのですが…

症状が出たり出なかったりするのは、プログラムの記述が不完全で、実行時の状況に依存してしまっているからです。

一例を上げると「ActiveSheet」の使い方が良くありません。
Excel単体で動作確認している時には問題ないでしょうが、PC上ではいろいろなプログラムが同時に動いています。
自分が起動したものだけではなく、バックグラウンドで動いているものも含めると、驚くほどたくさんのプログラムが動いています。

ですので、VBAで書いたプログラムの処理中、そのワークブックがずっとアクティブである保証はありません。

従って、どのワークブックのどのワークシートに属するセルまたはシェイプなのかを『明示』する必要があります。

セルやシェイプを Select してから、Selection に対して処理するやり方も、あまりオススメではありません。

詳しく説明しようとするととても長くなるので、下記のページなどを参考に考えて見てください。

〔ご参考〕
ブック、シートの基本的なルール

以上、ご参考まで

投稿2021/04/06 05:20

pi-chan

総合スコア5936

kawauso_

2021/04/06 09:32

pi-chan様ご回答ありがとうございます！仰る通りですね。そういう書き方は今後避けます。リンクも参考にさせて頂き、明日修正して動作確認してみます。また状況の方は追記させて頂きます。

kawauso_

2021/04/07 09:40

まず、「ActiveSheet」の使用を止めました。 10回中1～3回程度だったエラーが、10回中1回程度まで低減できました。ただ、図のselectやselectionをどういう風に置き換えたら良いか分からなかったので、引き続き調べてその部分も修正しようと思います。またご指摘頂いた箇所の修正ができたら追記させて頂きます。

pi-chan

2021/04/07 10:17

セルにしろシェイプにしろ、Selectできるということは、対象となるオブジェクトが何らかの仕方で指定できているのですよね！？そうであれば、それをわざわざ「Select」してから「Selection」に対して処理しようとしなくても、対象のオブジェクトに対して直接処理を実施すれば良いだけなのでは？？たとえば、２件目のソースコードであれば、 > For Each sp In ActiveSheet.Shapes の行で「sp」の中に対象となるオブジェクト（＝シェイプ）が順番に格納されて、それがある条件の場合のみ処理したいということですよね？そうであれば、 > sp.Select > Selection.CUt のようにするのではなく、 > sp.Cut といった具合に、対象のオブジェクトに対して直接処理を行えば良いはずです。

kawauso_

2021/04/08 01:01

ありがとうございます。まずは2件目のソースコードをそのように変更したところ、別のエラーが十中八九で頻発するようになりました。以下がそのエラーです。 ①そのうち9割はこちらのエラー　実行時エラー'-2147221040(800401d0)': 　'Cut'メソッドは失敗しました: 'Shape'オブジェクト　→sp.Cutに変更した箇所でエラーが発生します。 ②そのうち稀にこちらのエラー　実行時エラー '1004': 　'PasteSpecial'メソッドは失敗しました。'_Worksheet'オブジェクト　→sp.Cutの次の行(以下)でエラーが発生します。　　ws.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False 引き続き調べてみます。

kawauso_

2021/04/20 05:39

ご報告が遅くなりました。最終的に1件目は解決しました。 2件目はエラーが稀に出るものの、リトライすれば実行できるのでそれで良しとしました。 1件目は、画像の追加をAddPictureで行うことでエラーが全く出なくなりました。その他は教えて頂いた内容を修正しました。 2件目も教えて頂いた内容は修正しましたが、最初に挙げたエラーが稀に出るのは直りませんでした。ただ、こちらは複数回マクロを実行しても問題ないものなので、一旦解決済としたいと思います。今回教えて頂いた内容は今後マクロを作成する上でとても参考になりました。ありがとうございました。

行動規範の内容に同意します