入力シートで一括ボタン実行にしたいのですが、教えていただけますでしょうか。よろしくお願いいたします。

写真加工表を作成してます。
入力シートより、計算表、写真挿入を行っています。
シートは4枚です。
今回　入力シートのA1～A20に文字（写真図）を入力したときに
各シート4枚のE30,J30、O30,T30,Y30へ写真図（写真と図合成）を
一括ボタンで対応したいのです。
A1~A5→(sheet1)H40、M40,R40、W40、AB40　転記
A6~A10→(sheet2)H40、M40,R40、W40、AB40　転記
A11~A15→(sheet3)H40、M40,R40、W40、AB40　転記
A16~A20→(sheet4)H40、M40,R40、W40、AB40　転記

合成写真は各シートH50、M50、R50、W50、AB50　にあります。

現在、各シートへ　写真図と　削除を　ボタンにて実行してます。
下記です。

変更がある場合があるので、一度削除ボタンで割り当て先の図を削除して
写真図ボタンでコピー貼り付けして対応しています。

これを入力シートで変更があった場合も
一括ボタンで実行したいのですが、お願いいたします。
シートがアクティブの時でないと難しいのでわからいのです。

もう一つの表は、入力シート自体に写真をおいて、対応シートの該当する箇所へ
単純にコピペなら貼り付けはできましたが、削除ができないため、
やはり各シートでの確認もあるため、写真は各シートにおいて作成したいのです。

一括ボタンを押して、各シートの確認時にコピペができていれば最高です。

各シートに
Sub 削除()
Dim Obj As Object
Dim Cnt As Long
For Each Obj In ActiveSheet.DrawingObjects
If Not Intersect(Obj.TopLeftCell, Range("E30,J30,O30,T30,Y30")) Is Nothing Then
Obj.Delete
Cnt = Cnt + 1
End If
Next
End Sub

Sub 写真図()
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim Shape As Shape
For Each Shape In ActiveSheet.Shapes
If Intersect(Shape.TopLeftCell, [H50,M50,R50,W50,AB50]) Is Nothing Then
ElseIf Shape.TopLeftCell.Offset(-10) = "写真図" Then
Shape.Copy
Shape.TopLeftCell.Offset(-20, -3).PasteSpecial
End If
Next Shape
ActiveCell.Select
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

よろしくお願いいたします。

No.4 回答者： Qchan1962 回答日時： 2020/02/24 18:16

＞セルアドレス書いてあるけど、どのシート？

表題に書いてありますね。失礼しました。
やっぱり、作って欲しいのかな？プロの方には、申し訳ないのですが、
休日の暇つぶしに書いてみました。
回答の内容をしっかり検証してみてください。
元々の構成自体は、検討すべき所が、ありますが、、、。

各コード横のコメントをご覧ください。
　　EventsOFF　　'イベント制御　サブへ
は、よく使うのでサブに出しました。このようにすると、デバックなどで途中で止まっても、
Sub EventsON()を単独実行すれば、Eventなどが戻るので、私はこのようにしています。

Option Explicit
Sub 削除()
　　Dim Obj As Object
　　Dim TgtSht As Worksheet, startSht As Worksheet
　　EventsOFF　　'イベント制御　サブへ
　　Set startSht = ActiveSheet　　'現在のアクティブシートを変数に
　　For Each TgtSht In ActiveWorkbook.Worksheets　　　　'ブックの中のシートすべて
　　　　If TgtSht.Name <> "入力シート" Then　　　　　'入力シートを処理から除く
　　　　　　TgtSht.Activate　　'シートをアクティブにする
　　　　　　For Each Obj In ActiveSheet.DrawingObjects
　　　　　　　　If Not Intersect(Obj.TopLeftCell, Range("E30,J30,O30,T30,Y30")) Is Nothing Then
　　　　　　　　　　Obj.Delete
　　　　　　　　End If
　　　　　　Next Obj
　　　　End If
　　Next TgtSht
　　startSht.Activate　'アクティブシートを戻す
　　EventsON　　'イベント制御　サブへ
End Sub

'If Intersect(Shape.TopLeftCell, [H50,M50,R50,W50,AB50]) Is Nothing Then　全てをコピーする場合は、問題ないかもしれませんが、
'これに拘ると1枚だけとかの条件の時、分かりにくい。（方法としては、良いがFor Each で入るShapeが順番通りとは限らない）
'各シートには同じ処理を行っていますが、A1~A5→(sheet1)H40、M40,R40、W40、AB40　転記などの対応の関連性が、問題です。
'Shapeを名前などでコントロールするとかした方が、、とは思います。ご質問の構成だと限定的になってしまいますが、、取敢えず。


　　Dim Shape As Shape
　　Dim TgtSht As Worksheet, startSht As Worksheet
　　Dim i As Long, j As Long
　　Dim TgtShap As Variant
　　TgtShap = Sheets("入力シート").Range("A1:A20").Value　　'キーになるセル範囲を配列に（セル範囲は2次元）
　　EventsOFF　'イベント制御　サブへ
　　Set startSht = ActiveSheet　　'現在のアクティブシートを変数に
　　For Each TgtSht In ActiveWorkbook.Worksheets　　'ブックの中のシートすべて
　　　　If TgtSht.Name <> "入力シート" Then　'入力シートを処理から除く
　　　　　　TgtSht.Activate　　'シートをアクティブにする
　　　　　　For Each Shape In ActiveSheet.Shapes　'アクティブシートのすべてのShapeを
　　　　　　　　'If Intersect(Shape.TopLeftCell, [H50,M50,R50,W50,AB50]) Is Nothing Then
　　　　　　　　'方法としては、良いがFor Each で入るShapeが順番通りとは限らないので初歩的な条件式で（この場合の一例です。条件を設定すれば数行で済みます）
　　　　　　　　Select Case Shape.TopLeftCell.Address(False, False)　　　'Shapeのアドレスを検証（条件と関連性を持たせるため）
　　　　　　　　　　Case Is = "H50"　’アドレスで条件設定セル（配列）と関連性を持たせています。
　　　　　　　　　　　　i = 1
　　　　　　　　　　Case Is = "M50"
　　　　　　　　　　　　i = 2
　　　　　　　　　　Case Is > "R50"
　　　　　　　　　　　　i = 3
　　　　　　　　　　Case Is = "W50"
　　　　　　　　　　　　i = 4
　　　　　　　　　　Case Is = "AB50"
　　　　　　　　　　　　i = 5
　　　　　　　　　　Case Else
　　　　　　　　　　　　GoTo NextShap　　'該当しないShapeには処理しない
　　　　　　　　End Select

　　　　　　　　　　'メイン処理（わずか4行　^^；）　セル範囲　キー　TgtShap(j + i, 1)
　　　 If TgtShap(j + i, 1) = "写真図" Then 'メイン処理
　　　Shape.Copy
　　　Shape.TopLeftCell.Offset(-20, -3).PasteSpecial
　　　End If
NextShap:
　　　　　　Next Shape
　　　　　　'　　　　ActiveCell.Select　　　 '各シートのアクティブセルを選択したいなら、ここ（多分Shapeが選択されるのを解除しているだけ？）
　　　　　　Range("A1").Select　'A１セルを選択　　（不要なら削除）
　　　　　　j = j + 5　'シート移動ごとに配列番号を加算する
　　　　End If
　　Next TgtSht　'シートのループ終わり
　　startSht.Activate　　　　'アクティブシートを戻す
　　EventsON


'イベント制御系は、　サブへ出しました。
Sub EventsOFF()
　　With Application
　　　　.EnableEvents = False
　　　　.ScreenUpdating = False
　　End With
End Sub
Sub EventsON()
　　With Application
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
End Sub

Sub ～～()、End Subの付いていないコードに付いては、アドバイスです。
実行時エラーが発生するかもしれません。
デバッグなどを行い、確認の上、返信下されば、追加アドバイスいたします。

この回答へのお礼

素晴らしい　ご指導ありがとうございます。
構成自体の検討は、基本、本やネットを参考にしてるので
勉強不足だということは、重々承知ですが。
なかなかむつかしすぎますね；。
少しづつ勉強をしていってます。
今回、細かな配慮、指導等、
また、作成等　本当にありがとうございます。
先ほど拝見しました。いろんなアドバイス
今後に生かして勉強したいと思います。
先の#2の方の方法で、今回完成しました。
こちらの高度な方法も、いかしてみたいと思います。
今回、丁寧な対応ありがとうございました。

お礼日時：2020/02/24 20:53

No.3 回答者： Qchan1962 回答日時： 2020/02/24 15:51

＃２です。

お休みかな？
A1~A5→(sheet1)H40、M40,R40、W40、AB40　転記
A6~A10→(sheet2)H40、M40,R40、W40、AB40　転記
A11~A15→(sheet3)H40、M40,R40、W40、AB40　転記
A16~A20→(sheet4)H40、M40,R40、W40、AB40　転記
ここの変更の仕方が分らないのかな？
ElseIf Shape.TopLeftCell.Offset(-10) = "写真図" Then
セルアドレス書いてあるけど、どのシート？

しかし、この処理、限定条件（Shapeがないシートがある、2つしかない、沢山あるなど）無くすと、、少し面倒ですね。。多分
また、対象シェープの順番も壁になるかもしれません。。

この回答へのお礼

先に記載しましたが、思うことができました。
丁寧な対応、ありがとうございます。

お礼日時：2020/02/24 20:53

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2020/02/23 08:35

おはようございます。

＞現在、各シートへ　写真図と　削除を　ボタンにて実行してます。
＞シートがアクティブの時でないと難しいのでわからいのです。

シートをアクティブアクティヴにする方法が分からいと言う事ですか？
書き方、やり方は多々ありますが、、、

For Each Obj In ActiveSheet・・・
ループの前に対象シートをアクティブにして4シート繰り返せば良いのでは？
勿論、貼り付け先がシートごと違うのであれば、アクティブにするごとに指定するなどすれば

説明もコードもしっかりしているのですが、、処理内容が分からないのでしょうか？

Sub 削除()
Dim Obj As Object
Dim TgtSht As Worksheet
For Each TgtSht In ActiveWorkbook.Worksheets　　'ブックの中のシートすべて
　　　　TgtSht.Activate　’シートをアクティブにする
　　　　For Each Obj In ActiveSheet.DrawingObjects
　　　　　　If Not Intersect(Obj.TopLeftCell, Range("E30,J30,O30,T30,Y30")) Is Nothing Then
　　　　　　　　・・・
　　　　　　End If
　　　　Next Obj
　　Next TgtSht
End Sub

対象シート名が明確でブックに多数のシートがある場合はシート名を配列などに入れ処理をループ

　Dim TgtSht As Variant, i As Long
　　TgtSht = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4") 'シートを配列で指定
　　　For i = 0 To UBound(TgtSht) '指定したシートを順次実行
　　　　Sheets(TgtSht(i)).Activate
　　　　　For Each Obj In・・・

Sub 写真図()についても同様、、です

この回答へのお礼

ありがとうございました＾＾。
23日に、ご指導いただいた分で
少し追加したりして
思うことが完成しました。
記載されたものに近いところで実行できなかったので
質問に至り、やはり抜けや能力不足を感じました。
それでも、
こうして、丁寧に教えていただき
本当にありがとうございました。

お礼日時：2020/02/24 20:39

No.1 回答者： 銀鱗 回答日時： 2020/02/22 22:06

代わりに作ってほしいという作業依頼でしょうか。

そのマクロの中で何が分からないのかを考えてください。
そして実現したい機能をどこにどう追加するかを考えましょう。

その中で具体的に分からない点を質問すると良いでしょう。

「アクティブシートを切り替える方法が分からない」
「アクティブでないシートに対して作業を行う方法を知りたい」
のように具体的に質問しましょう。

自身で作成できなければ質問できませんよね。
作成依頼をするのであれば、専門業者にお金を出してお願いするようにしましょう。
特に業務で使っているような物であれば、尚更です。


・・・余談・・・

ベストアンサーが欲しいのか、自分はこれくらい簡単にできるという事を誇示したいのか、わかりませんが、
説明も解説もアドバイスも無しに、コードを示す人はいるにはいます。

この回答へのお礼

言葉足らずで意図も伝わりにくいことも
ご指摘ありがとうございました。
もっと、勉強をします。
その前に、質問を具体的に表現する、語学が
必要なのかもしれません。
この度は、ご指導ありがとうございました。

お礼日時：2020/02/24 20:56