[[20110607100212]]　『指定範囲内の図形をArray関数に放り込むやり方』（エクする？）　ページの最後に飛ぶ

『指定範囲内の図形をArray関数に放り込むやり方』（エクする？）

 シート上の特定範囲内に配置された図形をグループ解除または
 グループ化（再グループではない）または選択したい。

 グループ解除については下のコードで解決しましたが、
 グループ化（.Group）と選択（.Select）ができない。

 Sub Macro1()
     Dim myShape As Object
     Dim shTop As Integer
     Dim shLeft As Integer

     For Each myShape In ActiveSheet.Shapes
         shTop = myShape.Top
         shLeft = myShape.Left

         If shTop < 480 And shLeft < 720 And myShape.Type = msoGroup Then
             With myShape.DrawingObject
                 .ShapeRange.Ungroup.Select
             End With
         End If
     Next myShape
 End Sub

 自動記録では下のように。

     ActiveSheet.Shapes.Range(Array("Rectangle 1", "Line 2", "AutoShape 3")).Select
     Selection.ShapeRange.Group.Select

 Array関数のカッコの内容はシートごとに違うので、自動記録を
 そのまま使うことはできないけど、Array関数を活かしてグループ化
 や選択がしたい。シート上には他にも図形等のオブジェクトがある
 ので、範囲指定は必須です。

 といって、Array関数に特にこだわらないので、.Group と.Selectが
 したいです。なにか方法あるでしょうか？

 WindowsXP/Excel2002
 Windows2000/Excel2003

 ShapeのNameプロパティの値をとりあえず文字列としてくっつけておいて
 最後にSplitで配列にしてあげるのが簡単だと思います。

  Sub test()
  Dim myShape As Shape
  Dim myNames As String

  With ActiveSheet
    For Each myShape In .Shapes
      If myShape.Top < 480 And myShape.Left < 720 Then
        myNames = myNames & vbTab & myShape.Name
      End If
    Next myShape
    .Shapes.Range(Split(myNames, vbTab)).Group.Select
  End With
  End Sub

 （ｍｏｍｏ）

 （ｍｏｍｏ）さん、早速ありがとうございます。

 ご提示のやり方でエラーになりました。
 実行時エラー'1004': 指定したパラメータに無効な値が含まれています。

 myNameの値は下のようになっています。

 "	Rectangle 1	Line 2	AutoShape 3"

 Split(myNames, vbTab)のあたりかな、と思って調べてみましたが
 よく分からず、またアドバイスいただけますか？

 (エクする？)

 >.Shapes.Range(Split(myNames, vbTab)).Group.Select
 の部分を

 .Shapes.Range(Split(Mid$(myNames, 2), vbTab)).Group.Select

 にするとどうでしょうか？
 ""を回避しています。2007ではこれでも通ったんですが
 （ｍｏｍｏ）

 （ｍｏｍｏ）さん
 うーん、残念ながら2002,2003ではまだ同じエラーです。

 エラーが出る個所は上記の個所ですか？

 図形以外が含まれている可能性がありますか？
 >If myShape.Top < 480 And myShape.Left < 720 Then
 を
  If myShape.Top < 480 And myShape.Left < 720 And myShape.Type = msoAutoShape Then
 としてみるとか
 （ｍｏｍｏ）

 原因がわからないままですが、以下test2、test3も試してみてください。

  Sub test2()
  Dim myShape As Shape
  Dim myAry() As String
  Dim i       As Long

  With ActiveSheet
    ReDim myAry(1 To .Shapes.Count)
    For Each myShape In .Shapes
      If myShape.Top < 480 And myShape.Left < 720 And myShape.Type = msoAutoShape Then
        i = i + 1
        myAry(i) = myShape.Name
      End If
    Next myShape
    ReDim Preserve myAry(1 To i)
    .Shapes.Range(myAry).Group.Select
  End With
  End Sub

  Sub test3()
  Dim myAry() As Long
  Dim i       As Long
  Dim j       As Long
  With ActiveSheet
    ReDim myAry(1 To .Shapes.Count)
    For i = 1 To .Shapes.Count
      With .Shapes(i)
        If .Top < 480 And .Left < 720 And .Type = msoAutoShape Then
          j = j + 1
          myAry(j) = i
        End If
      End With
    Next i
    ReDim Preserve myAry(1 To j)
    .Shapes.Range(myAry).Group.Select
  End With
  End Sub

 （ｍｏｍｏ）

 なんとなくだけど、
 参照設定にて「Microsoft Office ○○ Object Library」のチェックが外れてませんか？
 BJ

 > エラーが出る個所は上記の個所ですか？

 そうです。同じくココ↓で引っ掛かります。

     .Shapes.Range(Split(Mid$(myNames, 2), vbTab)).Select

 図形以外が含まれている可能性がありますか？
 >If myShape.Top < 480 And myShape.Left < 720 Then
 を
  If myShape.Top < 480 And myShape.Left < 720 And myShape.Type = msoAutoShape Then
 としてみるとか

 msoAutoShape以外は、いまのところmsoLineとmsoTextBoxですかね。
 myShape.Type = msoAutoShape のコード有りでも無しでも
 同じ箇所で同じエラーです・・・。

 ・・・衝突しました。
 test2,3も試してみましたが、
      .Shapes.Range(myAry).Group.Select

 ここでやはり同じエラーになってしまいます。

 BJさん
 OfficeとExcelのObject Libraryでしたらちゃんとチェックが入っています。

 (エクする？)

 >OfficeとExcelのObject Libraryでしたらちゃんとチェックが入っています。
 あ～、入ってますか。
 先ほど下記コードで同じエラーがでて？？？？状態だったので。

 Dim shp As Shape
 Dim TB() As Variant
 For Each shp In ActiveSheet.Shapes
    i = i + 1
    ReDim Preserve TB(1 To i)
    TB(i) = shp.Name
 Next
 'ActiveSheet.Shapes.Range(TB).Select
 ActiveSheet.Shapes.Range(TB).Group
 Erase TB

 もしかして、Forms 2.0 Object Library のチェックが外れているのかな？
 と思い、Forms 2.0 Object Library の確認もせずにユーザーフォームを１個
 作りそのまま上記コードを走らせたら動いたもので・・・。

 確認をしてみるとForms 2.0 Object Libraryのチェックは外れたままだった。
 で、ひょっとしたら、「Microsoft Office ○○ Object Library」かな？
 と・・・。
 BJ

 >.Shapes.Range(myAry).Group.Select
 を
  Set myShape = .Shapes.Range(myAry).Group
  myShape.Select
 の2行に変更するとどうですか？

 原因が思いつかないですね。
 たとえば
 ActiveSheet.Shapes.Range(Array("Rectangle 1", "Line 2", "AutoShape 3")).Group
 だとどうなんですか？

 あとは、新規ブックで試してみるとか。
 （ｍｏｍｏ）

 お手数お掛けします・・・

 > >.Shapes.Range(myAry).Group.Select
 > を
 > Set myShape = .Shapes.Range(myAry).Group
 > myShape.Select
 > の2行に変更するとどうですか？

 Set myShape = .Shapes.Range(myAry).Group
 のところで同じエラーです。

 > ActiveSheet.Shapes.Range(Array("Rectangle 1", "Line 2", "AutoShape 3")).Group
 > だとどうなんですか？

 .Shapes.Range(myAry).Group.Select
 を
 .Shapes.Range(Array("Rectangle 1", "Line 2", "AutoShape 3")).Group
 だとエラーにならず、3個が1つのグループにまとまります。

 > あとは、新規ブックで試してみるとか。
 Excel再立ち上げして新規ブックで試しましたが、まったく同じ結果でした。

 (エクする？)

 BJさん

 > 先ほど下記コードで同じエラーがでて？？？？状態だったので。

 すみません、先ほどはコメント読み違えたかもしれないです。
 ご提示のコードでうまくグループ化（または選択）できました。
 運用環境でもう少し動作確認はしてみますが、取り急ぎ。

 でもBJさんのほうではエラーだった？のですか？

 (追記)
 あれ？でもよく見ると範囲指定がないかな？
 でもまずは自分でがんばってみます。

 (エクする？)

 私のtest2がエラーでBJさんのコードだとOKなのですか？
 ますます解らないですね。
 違いはIfで条件分岐しているかどうかくらいで、コードは違っても
 配列の要素や中身は同じのはずなんですが・・・

 だとしたら、条件に当てはまる図形が存在しない。というだけでは？
 （ｍｏｍｏ）

 同じワークシートでコード実行した上での結果です。
 テスト環境ですが、図形は「図形描写」ツールバーの四角形マークから
 起こした四角形を三つ、セルA1～C6の範囲に配置したのみ。 
 ローカルウィンドウでみても.TypeはmsoAutoShapeになっていますね。

 一応、全コード提示しますね。
 -----------------------------
 Sub Macro1()
    Dim myShape As Object
    Dim shTop As Integer
    Dim shLeft As Integer

    For Each myShape In ActiveSheet.Shapes
        shTop = myShape.Top
        shLeft = myShape.Left

        If shTop < 480 And shLeft < 720 And myShape.Type = msoGroup Then
            With myShape.DrawingObject
                .ShapeRange.Ungroup.Select
            End With
        End If
    Next myShape
 End Sub
 ----------------------------------
 Sub Macro2()

  Dim myShape As Object
  Dim myNames As String

  With ActiveSheet
    For Each myShape In .Shapes
      If myShape.Top < 480 And myShape.Left < 720 Then
        myNames = myNames & vbTab & myShape.Name
      End If
    Next myShape
    .Shapes.Range(Split(Mid$(myNames, 2), vbTab)).Select
  End With
 End Sub
 ----------------------------------

    Sub test2()
  Dim myShape As Shape
  Dim myAry() As String
  Dim i       As Long

  With ActiveSheet
    ReDim myAry(1 To .Shapes.Count)
    For Each myShape In .Shapes
      If myShape.Top < 480 And myShape.Left < 720 And myShape.Type = msoAutoShape Then
        i = i + 1
        myAry(i) = myShape.Name
      End If
    Next myShape
    ReDim Preserve myAry(1 To i)
  Set myShape = .Shapes.Range(myAry).Group
  myShape.Select
 End With

  End Sub
 ----------------------------------

  Sub test3()
  Dim myAry() As Long
  Dim i       As Long
  Dim j       As Long
  With ActiveSheet
    ReDim myAry(1 To .Shapes.Count)
    For i = 1 To .Shapes.Count
      With .Shapes(i)
        If .Top < 480 And .Left < 720 And .Type = msoAutoShape Then
          j = j + 1
          myAry(j) = i
        End If
      End With
    Next i
    ReDim Preserve myAry(1 To j)
  Set myShape = .Shapes.Range(myAry).Group
  myShape.Select

  End With
  End Sub
 ----------------------------------

 Sub bj()
    Dim shp As Shape
    Dim TB() As Variant
    For Each shp In ActiveSheet.Shapes
        i = i + 1
        ReDim Preserve TB(1 To i)
        TB(i) = shp.Name
    Next
    'ActiveSheet.Shapes.Range(TB).Select
    ActiveSheet.Shapes.Range(TB).Group
    Erase TB
 End Sub
 ----------------------------------

 最後のSub bj()でグループ化したものは、最初のSub Macro1()で
 グループ解除できます。

 グループ化する前の状態（またはグループ解除した状態）で実施して、
 真ん中の３つはエラーなのです。コードは基本コピペです。
 何かお気づきの点はあるでしょうか？

 (エクする？)

 エラーになるプロシージャの
 If　と　EndIf　の行をコメントアウトして実行したらどうなりますか？
 それで理想どおり出来るのであれば
 範囲の条件が間違っているんだと思います。
 （ｍｏｍｏ）

 > If　と　EndIf　の行をコメントアウトして実行したらどうなりますか？

 これもすべて同じ箇所で同じエラーになってしまいます。
 他に切り分け方法ありますでしょうか。

 （エクする？）

 エラーの原因というか、
 こんなだったっけか？？と自分で首を傾げてますが。

 Dim myAry() As String
                  ↑
                Variant 型にしてみそ。
 BJ

 > Variant 型にしてみそ。

 あ、できた。test2,3ともできました。

 （ｍｏｍｏ）さん、BJさん
 助かりました。本当にありがとうございました。

 え・・・そんな原因？
 BJさんフォローありがとうございます。

 Array関数がVariant型を返すのはわかりますけど
 ShapesのRangeプロパティって融通利かないんですね・・・
 しかも２００７だとなんの問題も無いって不思議。
 （ｍｏｍｏ）

初めまして。
2007ではOKですが、2003ではエラーになるようですね。
以下の方法ならもどちらでも通ると思います。

Sub Macro1()

     Dim myShape As Object
     Dim shTop As Integer
     Dim shLeft As Integer
     For Each myShape In ActiveSheet.Shapes
         shTop = myShape.Top
         shLeft = myShape.Left
         If shTop < 480 And shLeft < 720 And myShape.Type <> msoGroup Then
             myShape.Select (False)
         End If
     Next myShape
     Selection.Group
 End Sub

あらかじめ、図が選択されていない事が前提になっていますので、
必要なら、セルのSelect等を入れる必要があると思います。

このようん場所での回答はほとんどしたことがないので、
回答方法がこれで良いのか不安ですが・・・
（Yama）

前回答をしてから気づきました。
2003では、Shapes.Rangeに指定する配列は、
Variant型である必要があるようです。

つまり、
myShape.Nameを入れる配列をVariantで定義すれば通ります。
（Yama）

 （Yama）さん、ありがとうございます。できました。

 .Select (False)

 というワザ、初めて見ました。勉強になりました。

 (エクする？)

コメント返信：

[ 一覧(最新更新順) ]

[[20110607100212]] 『指定範囲内の図形をArray関数に放り込むやり方』（エクする？） ページの最後に飛ぶ

[[20110607100212]]　『指定範囲内の図形をArray関数に放り込むやり方』（エクする？）　ページの最後に飛ぶ