[[20200114104539]]　『(マクロ)　セル選択範囲に何らかの図形(Shape)がａx（マイン）　ページの最後に飛ぶ

『(マクロ)　セル選択範囲に何らかの図形(Shape)があれば選択する方法』（マイン）

お世話になっております。

任意のセル選択範囲内に配置されてある
何らかの図形(Shape)を
選択する方法

についてアドバイスをお願いします。

※選択セル範囲は不規則な結合セルも含まれています。

・コードを実行すると

　図形を選択できたりできなかったりし途中でエラーがでます

　エラー13
　型が一致しません

　↓

　'図形がセル選択範囲と重なっているときに図形処理
　　If Not (Intersect(rng, Selection) Is Nothing) Then

Sub 選択範囲内の選択と設定()

    Dim SHP As Shape
    Dim rng As Range
    If TypeName(Selection) <> "Range" Then Exit Sub

    For Each SHP In ActiveSheet.Shapes
        '図形のあるセル範囲をセット
        Set rng = Range(SHP.TopLeftCell, SHP.BottomRightCell)

        '図形がセル選択範囲と重なっているときに図形処理
        If Not (Intersect(rng, Selection) Is Nothing) Then　　'←エラー

            With SHP
                '選択
                .Select False

' 'サイズを調整0.6*0.6
' .Object.Height = 0.6
' .Object.Width = 0.6
' '左揃え
' .ShapeRange.Align msoAlignLefts, msoFalse

            End With
        End If
    Next
End Sub

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

重なっているかどうかの判定を、Selectionで行っているせいですね。 1つ目の図形を見つけると、それをSelectしているので、Selectionが変わってしまいますから。

解決策は、Range型の変数を1つ追加して、最初のSelectionを代入しておくと良いでしょう。
（???） 2020/01/14(火) 11:17

???さん
アドバイスありがとうございます。

参考に仕様を変えて下記の通りにするとできました。

Sub 選択範囲内の選択と設定()

    Dim SELECT_Add As String
    Dim SELECT_She As Shape
    Dim SELECT_Obj As DrawingObjects

    'セル範囲の取得(選択されているセル範囲のアドレスを取得)
    If TypeName(Selection) <> "Range" Then Exit Sub
    SELECT_Add = Selection.Address(False, False)

    '図形選択(完全にセル範囲に配置されている図形を順次選択)
    For Each SELECT_She In ActiveSheet.Shapes

        If Not Intersect(SELECT_She.TopLeftCell, Range(SELECT_Add)) Is Nothing _
           And Not Intersect(C.BottomRightCell, Range(SELECT_Add)) Is Nothing Then
            SELECT_She.Select False
        End If

    Next SELECT_She

    '図形の設定(選択状態の図形を設定)
    Set SELECT_Obj = ActiveWindow.Selection

    With SELECT_Obj
        If .Count <> 0 Then
            'オブジェクトサイズを調整0.6*0.6(1mm=2.83465pt)
            .Height = 17
            .Width = 17
            'オブジェクトを左揃え
            .ShapeRange.Align msoAlignLefts, msoFalse
        End If
    End With

End Sub
（マイン） 2020/01/14(火) 17:33

すみません

コードは

図形が選択セル内に「完全に収まっている」ものに対する処理です。

これを、

図形が選択セル内に「一部でも入っている」場合も処理の対象にする

としたいのですが
コードはどの部分を修正すればよろしいでしょうか？

何卒アドバイスのほどよろしくお願いいたします。

（マイン） 2020/01/14(火) 17:44

提示されたコードが理解出来ているなら、じっくり考えれば分かりそうな気がしますけど・・・・(特にIntersectメソッドが、どんなセルを返しているのか)
とりあえず、???さんのアドバイスどおり、【Range型】の変数を1つ追加するところから手を付けてはどうでしょうか？

また、↓あたりが参考になりそうに思います。
https://www.relief.jp/docs/excel-vba-set-range-variable-area-shapes.html
https://www.relief.jp/docs/excel-vba-select-all-shapes.html

    Sub 実験()
        Dim 選択範囲 As Range
        Dim シェイプ As Shape
        Dim i As Long

        Range("C5:I16").Select
        Set 選択範囲 = Selection

        For Each シェイプ In ActiveSheet.Shapes
            If Not Intersect(Range(シェイプ.TopLeftCell, シェイプ.BottomRightCell), 選択範囲) Is Nothing Then
                シェイプ.Select Replace:=False
            End If
        Next

        On Error Resume Next
        i = Selection.ShapeRange.Count
        On Error GoTo 0

        If i > 0 Then
            With Selection.ShapeRange
                .Height = 17
                .Width = 17
                .Align msoAlignLefts, msoFalse
            End With
        End If

    End Sub

（もこな２） 2020/01/14(火) 18:25

もこな2さん

いつもありがとうございます。

セル範囲に図形の一部が含まれる場合の処理についてしっかりと動いています。

なぜそうなるのか、色々と検証してみます。
（マイン） 2020/01/15(水) 09:53

＞なぜそうなるのか
繰り返しになりますけど、Intersectメソッドが何を返しているか考えるのが肝です。

http://officetanaka.net/excel/vba/tips/tips118.htm
↑をみれば、わかるとおもいますが、Intersectメソッドは２つ以上の【セル範囲】が重なっている範囲を返し、重なっているセルが一つも無いときはNothingを返します。

したがって、 Intersectメソッドの返り値を考えれば「and」を使わなくても

 「Nothing」でない　→　「一部」あるいは「全部」が重なっている
      〃    である　→　重なっている部分は無い

という分岐ができます。

なので、当初のアドバイスに沿って「Range型」の変数を追加すれば、わずか数行の修正で良かったはずです。
（コメントアウトされていた部分の整理は除く）

    Sub 最初のコード_修正版()
        Dim SHP As Shape
        Dim rng As Range
        Dim 選択範囲 As Range                                       '←追加

        If TypeName(Selection) <> "Range" Then Exit Sub
        Set 選択範囲 = Selection                                    '←追加

        For Each SHP In ActiveSheet.Shapes
            Set rng = Range(SHP.TopLeftCell, SHP.BottomRightCell)

            If Not Intersect(rng, 選択範囲) Is Nothing Then        '←修正（Selectionを変更,不要な括弧を削除）
                SHP.Height = 17
                SHP.Width = 17
                SHP.Select False
            End If
        Next SHP

        On Error Resume Next                                        '←実行時エラーが発生しても次へ進むよう設定
        Selection.ShapeRange.Align msoAlignLefts, msoFalse          '←Selection.ShapeRangeが１つも無いと実行時エラー
        On Error GoTo 0                                             '←エラートラップ解除

    End Sub

ちなみに、今回は違うようですが選択範囲に"完全に"含まれているシェイプのみ対象にするほうがちょっとだけめんどくさいとおもいます。

    Sub 選択範囲内に完全に含まれるシェイプのみ()
        Dim SHP As Shape
        Dim rng As Range
        Dim 選択範囲 As Range

        If TypeName(Selection) <> "Range" Then Exit Sub
        Set 選択範囲 = Selection

        For Each SHP In ActiveSheet.Shapes
            Set rng = Range(SHP.TopLeftCell, SHP.BottomRightCell)

            If Not Intersect(rng, 選択範囲) Is Nothing Then

                '  「Intersectの返り値（セル(範囲)）」と「rng（セル(範囲))」が同じか
                '▼（Addressプロパティを使って）判定している
                If rng.Address = Intersect(rng, 選択範囲).Address Then
                    SHP.Height = 17
                    SHP.Width = 17
                    SHP.Select False
                End If
            End If
        Next SHP

        On Error Resume Next
        Selection.ShapeRange.Align msoAlignLefts, msoFalse
        On Error GoTo 0

    End Sub

（もこな２） 2020/01/15(水) 12:11

コメント返信：

[ 一覧(最新更新順) ]

[[20200114104539]] 『(マクロ) セル選択範囲に何らかの図形(Shape)がａx（マイン） ページの最後に飛ぶ

[[20200114104539]]　『(マクロ)　セル選択範囲に何らかの図形(Shape)がａx（マイン）　ページの最後に飛ぶ