ある範囲の図形を選択

質問

EXCELで、ある範囲の図形を選択するマクロが組みたいのですが、
マクロの自動記録でオブジェクトの選択ボタンで範囲指定をすると、
マクロ自体はPicture4,Picture5,…というように
各図形として判断しているようで、範囲内の選択というわけにはいかないようで困っています。

私がやろうとしているのは、すでにひとつの図形（日本地図）があり、
その上に貼り付けられた図（都市の写真）のみ選択したいのです。
選択したい図（都市の写真）の名前は都度かわるため、Picture4,Picture5,…となると、別の名前のものが貼り付けられたときに認識しないので困るのが一点、もう一点は、既に地図が貼り付けられた状態で、この地図自体は選択には入れないで地図の内側の範囲内にある都市の写真のみを選択したいという二点が課題で・・どうしたらよいものか困っています。

回答No.5

masa_019

>写真の中にグループ化されていた写真が混じっていました。

確かに、グループ化された写真が混じっていると、
エラーになりますね。気が付きませんでした。
画像が存在するときにも「地図上に画像が存在しません。」の
メッセージが出る件ですが、
エラーが無いときは ErrorHandler:以下が実行されないように、
Exit Sub　でプロシージャを抜ける必要があります。

以下のような感じでしょうか。

Sub 地図上の画像選択1_1()

Dim r1 As Range
Dim r2 As Range
Dim p As Picture
Dim ary() As String
Dim i As Integer

i = 0

With ActiveSheet.Pictures("Picture 3")
Set r1 = Range(.TopLeftCell, .BottomRightCell)
End With

For Each p In ActiveSheet.Pictures
Set r2 = Range(p.TopLeftCell, p.BottomRightCell)
If Not Application.Intersect(r1, r2) Is Nothing And p.Name <> "Picture 3" Then
ReDim Preserve ary(i)
ary(i) = p.Name
i = i + 1
End If
Next

Set r1 = Nothing
Set r2 = Nothing

On Error GoTo ErrorHandler:
ActiveSheet.Pictures(ary).Select
Exit Sub　　'←この1行を追加
ErrorHandler: MsgBox "地図上に画像が存在しません。"

End Sub

お礼

ありがとうございます！！！
できましたっっ(*^o^*)
この度は本当にいろいろと教えていただき、ありがとうございます。
ぶ厚い本を購入していろいろ読んだのですがなかなか思い通りにいかず
すごく困っていたのですが、お蔭様で完成しました♪
これで仕事がスムーズに捗ります！
もぅ何とお礼を申し上げてよいやら・・というほど感動です！
本当にありがとうございました！

回答No.4

masa_019

>Picturesクラスのselectメソッドに失敗しました。

ごめんなさい。
正直言って実際のシートを見てみないことには
エラーの理由はわかりません。
（見てもわからないかもしれませんが・・・）

あてずっぽうですが、シートを保護しているとかありませんか？

お礼

お礼が遅くなって申し訳ありません。
エラーの原因が何かよくわからなくて何度もやっていたら
写真の中にグループ化されていた写真が混じっていました。
エラーの原因はそれだったようです。
お手数おかけしました。
ありがとうございました。

実は今、マクロを登録した画像選択ボタンを作ったのですが、
もしも地図上に画像（都市の写真）が１枚も存在しなかったときに
エラーが出てしまいます。
もし都市の写真が１枚も存在しないのに画像選択ボタンを押してしまったら「地図上に画像が存在しません。」というメッセージを表示させたくて本を見ながら入れてみたのですが・・・うまくいきません。なぜか画像が存在するときにもこのメッセージが表示されます。。。
やはりエラー処理の入れ方が間違っているのでしょうか？
もしよろしければアドバイスをいただけると助かります。
本当にすみません。

Sub 地図上の画像選択1_1()

Dim r1 As Range
Dim r2 As Range
Dim p As Picture
Dim ary() As String
Dim i As Integer

i = 0

With ActiveSheet.Pictures("Picture 546")
Set r1 = Range(.TopLeftCell, .BottomRightCell)
End With

For Each p In ActiveSheet.Pictures
Set r2 = Range(p.TopLeftCell, p.BottomRightCell)
If Not Application.Intersect(r1, r2) Is Nothing And p.Name <> "Picture 546" Then
ReDim Preserve ary(i)
ary(i) = p.Name
i = i + 1
End If
Next

On Error GoTo ErrorHandler:

ActiveSheet.Pictures(ary).Select
Set r1 = Nothing
Set r2 = Nothing

ErrorHandler:MsgBox"地図上に画像が存在しません。"

End Sub

回答No.3

ja7awu

> 作業とは別に
> この選択した図を削除するには「Delete」をどこかにつけなければ
> いけないのだと思うのですが、どこにつければよいでしょうか？

「この作業と別」　ということですが、選択が目的ではなく、削除だけの場合は、
コード上の削除する時点が変わってきます。

◎ 先のように該当する図形を選択し、MsgBoxで「削除するか？」にYesを選択した
　場合は、削除し、Noを選択した場合は、選択状態のままにするのであれば、
　こんな感じです。(先のコードにDeleteを付加する)

Sub 範囲内図形削除()
Dim Pic As Picture
Dim Rng As Range
Dim Cnt As Long
If TypeName(Selection) = "Range" Then
　　Set Rng = Selection
　　For Each Pic In ActiveSheet.Pictures
　　　　If Not Intersect(Rng, Pic.TopLeftCell) Is Nothing Then
　　　　　　If Not Intersect(Rng, Pic.BottomRightCell) Is Nothing Then
　　　　　　　　If Cnt = 0 Then
　　　　　　　　　　Pic.Select
　　　　　　　　Else
　　　　　　　　　　Pic.Select (False)
　　　　　　　　End If
　　　　　　　　Cnt = Cnt + 1
　　　　　　End If
　　　　End If
　　Next
　　If Cnt = 0 Then
　　　　MsgBox "該当する図形は、見つかりません。", vbExclamation
　　Else
　　　　If MsgBox(Cnt & " 個の図形が見つかりました。" & String(2, vbLf) & _
　　　　　　"削除しますか？", vbYesNo + vbQuestion) = vbYes Then Selection.Delete
　　End If
Else
　　MsgBox "セル範囲を選択してください。"
End If
Set Rng = Nothing
End Sub

◎ 該当図形を選択せず、即 削除する場合は、こんな感じです。

Sub 範囲指定図形削除()
Dim Pic As Picture
Dim Rng As Range
Dim Cnt As Long
If TypeName(Selection) = "Range" Then
　　Set Rng = Selection
　　For Each Pic In ActiveSheet.Pictures
　　　　If Not Intersect(Rng, Pic.TopLeftCell) Is Nothing Then
　　　　　　If Not Intersect(Rng, Pic.BottomRightCell) Is Nothing Then
　　　　　　　　Pic.Delete
　　　　　　　　Cnt = Cnt + 1
　　　　　　End If
　　　　End If
　　Next
　　If Cnt = 0 Then
　　　　MsgBox "該当する図形は、見つかりません。", vbExclamation
　　Else
　　　　MsgBox Cnt & " 個の図形を削除しました。"
　　End If
Else
　　MsgBox "セル範囲を選択してください。"
End If
Set Rng = Nothing
End Sub

コードを解析して、実情に合わせた形のコードにされたら良いと思います。

お礼

ありがとうございます。
該当図形を選択せず即削除の方法で行わせていただくことにしました。
わがままを言ってお手数をおかけしました。
すごく助かりました。
本当に感謝です！

回答No.2

masa_019

こんにちは。

日本地図の名前を "Picture 1" として、
この日本地図と少しでも重なっている、
その他の図を全て選択するとして、

Sub Sample()

Dim r1 As Range
Dim r2 As Range
Dim p As Picture
Dim ary() As String
Dim i As Integer

i = 0

With ActiveSheet.Pictures("Picture 1")
Set r1 = Range(.TopLeftCell, .BottomRightCell)
End With

For Each p In ActiveSheet.Pictures
Set r2 = Range(p.TopLeftCell, p.BottomRightCell)
If Not Application.Intersect(r1, r2) Is Nothing And p.Name <> "Picture 1" Then
ReDim Preserve ary(i)
ary(i) = p.Name
i = i + 1
End If
Next

ActiveSheet.Pictures(ary).Select
Set r1 = Nothing
Set r2 = Nothing

End Sub

お礼

ありがとうございます。
私の思い通り図を選択することができました。
初心者の私でも希望通りのことができそうです。
本当に本当に助かりました。
本当にありがとうございました！

補足

昨日はありがとうございました。
実は、教えて頂いたとおりにコードを貼り付け使用しているのですが、
日本地図上にある都道府県の写真を日本地図の横にある
文章のあたりに移動して、改めて『日本地図上にある都道府県の写真のみ選択』を実行すると、「ActiveSheet.Pictures(ary).Select」のところでどうしてもエラーになってしまいます。

エラーになるのは、
都道府県の写真を横の文章のあたり１～３枚移動した場合のみ
（４枚以上を移動した場合にはエラーはでません）
エラーの内容は、
実行時エラー1004
Picturesクラスのselectメソッドに失敗しました。

もし教えて頂けると助かります。
お手数おかけして申し訳ありません。

回答No.1

ja7awu

セルを選択し、その中にスッポリ入っている図形を選択する　ということで
宜しければ、こんな感じで如何でしょうか。

もし、セル選択範囲に図形の左上隅だけが入っているものだけを選択したい場合は、
後の If Not Intersect ～ と対応する　End If を削除します。(9、16行目)

Sub 範囲内図形選択()
Dim Pic As Picture
Dim Rng As Range
Dim Cnt As Long
If TypeName(Selection) = "Range" Then
　　Set Rng = Selection
　　For Each Pic In ActiveSheet.Pictures
　　　　If Not Intersect(Rng, Pic.TopLeftCell) Is Nothing Then
　　　　　　If Not Intersect(Rng, Pic.BottomRightCell) Is Nothing Then
　　　　　　　　If Cnt = 0 Then
　　　　　　　　　　Pic.Select
　　　　　　　　Else
　　　　　　　　　　Pic.Select (False)
　　　　　　　　End If
　　　　　　　　Cnt = Cnt + 1
　　　　　　End If
　　　　End If
　　Next
　　MsgBox Cnt & " 個の図形を選択しました。"
Else
　　MsgBox "セル範囲を選択してください。"
End If
Set Rng = Nothing
End Sub

お礼

ありがとうございます。
とても助かります。
実は、私が行おうとしている日本地図上の作業とは別に
あるセル範囲内での図形の削除というのもしなければならなかったので
そちらもすごく悩んでいたのですが、
こちらの方法を使わせていただきたいと思います。
ご親切に教えて頂けて、本当に嬉しいです。

この選択した図を削除するには「Delete」をどこかにつけなければ
いけないのだと思うのですが、どこにつければよいでしょうか？
重ね重ねすみません。

もし教えていただければ助かります。