[[20200626163443]]　『複数シートにある、同じセル範囲の画像を一括削除』（96）　ページの最後に飛ぶ

『複数シートにある、同じセル範囲の画像を一括削除したい』（96）

ひな形のようなものがあり、一つ目のシートに入力すると必要箇所が他の各シートに自動的に入力されるExcelファイルを作っています。
画像を全てのシートで同じセル範囲に貼り付けています。
この画像を一括で削除したいです。（画像が変更された場合、貼り付ける時にコピー＆ペーストするマクロを使っているので、一度削除しないと重複する為）
欄外の図形にマクロの登録をしてあるので、一定のセル範囲のみ削除したいです。

下記マクロのようなことがしたいのですが、品番ごとに原本のExcelファイルをコピーしてファイル名を変えてしまうので、ファイル名の絡まないマクロを教えて頂きたいです。

Sub 画像削除用()

'指定したセルに含まれる画像・図形等削除

 Dim myRng As Range
 Dim sp As Variant
 Set myRng = Range("D21:U77")
 For Each sp In ActiveSheet.Shapes
 If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
 sp.Delete
 End If
 Next
 Set myRng = Nothing

End Sub

Sub 画像削除()

    Application.Run "'原本.xlsm'!画像削除用"     
    Sheets("シート2").Select
    Application.Run "'原本.xlsm'!画像削除用"
    Sheets("シート3").Select
    Application.Run "'原本.xlsm'!画像削除用"
    Sheets("シート4").Select
    Application.Run "'原本.xlsm'!画像削除用"
    Sheets("シート5").Select
    Application.Run "'原本.xlsm'!画像削除用"
    Sheets("シート6").Select
    Application.Run "'原本.xlsm'!画像削除用"
    Sheets("シート7").Select
    Application.Run "'原本.xlsm'!画像削除用"

    'シート1へ戻る
    Sheets("シート1").Select
    Range("Y23:AM29").Select

End Sub

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

 こんばんは！
外してる可能性が大ですが、想像力をMaxにして書いてみました。。。
要は、原本のBookから複写したBookの図形を削除するのですよね？？？
サブルーチンにBookとシートを渡して削除すればいいと思います。

 で、ということは少なくともBookが二つあるわけですよね？
そういう時は、どこの誰というように明示しないと可読性が落ちますし上手く行ってもそれはたまたまです。
再現性が期待出来ません。
この↓コードでも　ActiveWorkbook　を使用しているのであまりお勧めは出来ませんが、
それはそれで運用上ありな場合もありますので今回はあえてそうしています。
今後の課題ですね。。。

 Option Explicit
Sub 画像削除用(ByVal MyWb As Workbook, ByVal MySh As String)
'指定したセルに含まれる画像・図形等削除
Dim myRng As Range
Dim sp As Variant
With MyWb
    Set myRng = .Sheets(MySh).Range("D21:U77")
    For Each sp In .Sheets(MySh).Shapes
        If Not Intersect(.Sheets(MySh).Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
            sp.Delete
        End If
    Next
End With
Set myRng = Nothing
End Sub
Sub 画像削除()
Dim x As Variant
Dim i As Long
x = Array("シート2", "シート3", "シート4", "シート5", "シート6", "シート7")
For i = LBound(x) To UBound(x)
    画像削除用 ActiveWorkbook, x(i)
Next
With ActiveWorkbook
    'シート1へ戻る
    .Sheets("シート1").Select
    .Sheets("シート1").Range("Y23:AM29").Select
End With
End Sub
（SoulMan） 2020/06/26(金) 21:24

SoulManさん

初めまして。
ご回答いただきありがとうございます。

すみません、わかりづらい説明でしたね…。
原本となるBookを作っておき、使用時にはコピーして別のBookとして使用します。
使用時に開かれるBookは一つです。

　　Sub 画像削除()

    Application.Run "'原本.xlsm'!画像削除用"     ←原本作成時に組んだのでタイトルが原本です
    Sheets("シート2").Select

使うときは、コピーしたBookのタイトルを品番に変えて使っていきます。
その為、マクロにタイトルが含まれる私の組んでみたのだと使えず、お手上げになってしまいました。

.
.
「ひな形のようなものがあり、一つ目のシートに入力すると必要箇所が他の各シートに自動的に入力される」というのは、下記のような感じで、Bookのシート1に貼った画像を他全シートの同じセル範囲にコピーして貼り付けていきます。
本当はループ処理とかしたらいいのかもしれませんが、初心者なので記録させて少し変えて使っております。
下記のように貼り付けた全シートD21:U77の範囲内の画像を削除したいです。

Sub 画像貼り付け()

    'シート1の画像をコピー
    Range("D21:U77").Select
    Selection.Copy

    '各シートに貼り付け
    Sheets("シート2").Select
    Range("D21:U77").Select
    ActiveSheet.Paste

    Sheets("シート3").Select
    Range("D21:U77").Select
    ActiveSheet.Paste

    Sheets("シート4").Select
    Range("D21:U77").Select
    ActiveSheet.Paste

    Sheets("シート5").Select
    Range("D21:U77").Select
    ActiveSheet.Paste

    Sheets("シート6").Select
    Range("D21:U77").Select
    ActiveSheet.Paste

    Sheets("シート7").Select
    Range("D21:U77").Select
    ActiveSheet.Paste

    'シート1へ戻る
    Sheets("シート1").Select
    Range("Y23:AM29").Select
    Application.CutCopyMode = False

End Sub

.
.
SoulManさんが組んでくださったものをコピペしてみたのですが、シート1の画像しか削除されませんでした。
Bookが二つある前提で作ってくださっていたから違うのだろうとは思ったのですが、ActiveWorkbookがよくわからず…標準モジュールへの貼り付けではダメなのでしょうか？
（96） 2020/06/29(月) 11:35

横からですが。

■１
なんでプロシージャ分けたのですか？
分ける意味がよく分からないです。

■２
プロシージャを分けるにしても、なんでRanメソッドで実行するのですか？
同じプロジェクト、もっと言うと同じモジュールに記述するのではないのですか？

■３
＞使用時に開かれるBookは一つです。
ってことは、マクロで操作したいブックは自ブックということですか？

（もこな２） 2020/06/29(月) 19:28

もこな２さん

はじめまして。
少しだけ勉強してみてはいるのですが、まだまだ記録したり、ネットで同じ条件の物を探してきて少し変える程度の初心者なので、ご質問の意図に添えていなかったら申し訳ないです。

.
■１
プロシージャ、というのは「Sub ()～End Sub」までのことですよね？
画像削除用と画像削除のがわけてあることでしょうか？

画像削除用のマクロは、ネットで検索して他で使っていたので、これを応用すれば…？と思い、コピペして持ってきたものでした。
画像削除のマクロは、これで出来ないかな？と画像削除用のマクロを使ったのを記録させてみた結果です。

やりたいこと自体は出来たのですが、前述の通りタイトルが入ってきてしまうとダメで今回ご質問させていただいておりました。

.
■２
すみません。不勉強なもので、Ranメソッド等があまりわかりません…。
画像削除のマクロですかね？
こちらでしたら、記録させたもので、全て同じ標準モジュールに書いてあります。

.
■３
そうですね！自ブックとなります。
うまい言い方が思いつきませんでした。
ありがとうございます！

（96） 2020/06/30(火) 11:20

↓全てというのは、貼り付け・削除用・削除のマクロになります。
　ここに記載していないマクロ含めて全て同じ標準モジュール、同じModule内です。
■２
こちらでしたら、記録させたもので、全て同じ標準モジュールに書いてあります。
（96） 2020/06/30(火) 11:33

SoulManさんが記述してくださったものを弄ってみていたら一応出来ましたので、記載しておきます。
もしこうした方がいいというのがございましたら、ご指摘お願い出来たらと思います。

.
Option Explicit
Sub 画像削除用(ByVal MyWb As Workbook, ByVal MySh As String)

 '指定したセルに含まれる画像・図形等削除
 Dim myRng As Range
 Dim sp As Variant
 With MyWb
    Set myRng = .Sheets(MySh).Range("D21:U77")
    For Each sp In .Sheets(MySh).Shapes
        If Not Intersect(.Sheets(MySh).Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
            sp.Delete
        End If
    Next
 End With
 Set myRng = Nothing
End Sub

Sub 画像削除()

 Dim x As Variant
 Dim i As Long
 x = Array("シート1", "シート2", "シート3", "シート4", "シート5", "シート6", "シート7")
 For i = LBound(x) To UBound(x)
    画像削除用 ActiveWorkbook, x(i)
 Next
 With ActiveWorkbook

  'シート1へ戻る
  .Sheets("シート1").Select
  .Sheets("シート1").Range("Y23:AM29").Select
 End With
End Sub

.
変えさせていただいたのは、「x = Array("シート1",…」とシート1を含めた点です。
削除用でシート1を消し、削除で他全てを消すマクロだったのでしょうか？
上手くコピペが出来ていなかったりしたのかもしれません…。

どういうマクロなのか読み取れず、理解出来ず、また上手く説明出来なかった事、申し訳ないです。
本当に助かりました！
（96） 2020/06/30(火) 13:07

コメント返信：

[ 一覧(最新更新順) ]

[[20200626163443]] 『複数シートにある、同じセル範囲の画像を一括削除』（96） ページの最後に飛ぶ

[[20200626163443]]　『複数シートにある、同じセル範囲の画像を一括削除』（96）　ページの最後に飛ぶ