指定範囲内のオートシェイプを数える方法
- I5:I24の範囲内のオートシェイプの数を数えるマクロを作成したいが、範囲指定の方法が分からない。
- マクロの中で、指定範囲のオートシェイプをループして数える方法を教えてほしい。
- マクロの中にどこにコードを追加すれば指定範囲内のオートシェイプを数えることができるか教えてほしい。
- ベストアンサー
指定範囲内のオートシェイプを数えるには？
I5:I24の範囲内のオートシェイプの数を数え、I25に合計数を表示させるマクロを作っているのですが、どうしても範囲指定の仕方が分かりません。教えてください。 'オートシェイプの合計数算出 Dim shp As Object Dim cnt As Long For Each shp In ActiveSheet.Shapes If shp.Type = msoAutoShape Then If shp.TopLeftCell.Column = 9 Then cnt = cnt + 1 End If End If Next shp Range("I25").Value = cnt このマクロのどこにどう入れればよいでしょうか？
- noa8998
- お礼率51% (74/144)
- オフィス系ソフト
- 回答数3
- ありがとう数3
- みんなの回答 （3）
- 専門家の回答
質問者が選んだベストアンサー
TopLeftCellプロパティとIntersect メソッドを使って 図形の左上端が範囲内にあるか判定します Dim shp As Object Dim cnt As Long For Each shp In ActiveSheet.Shapes If shp.Type = msoAutoShape Then If Not Intersect(shp.TopLeftCell, Range("I5:I24")) Is Nothing Then cnt = cnt + 1 End If End If Next shp Range("I25").Value = cnt 図形の右下も含めるのならBottomRightCellプロパティ も条件に含めてください
その他の回答 (2)
- imogasi
- ベストアンサー率27% (4737/17068)
もともとオートシェイプなどの、シート上のオブジェクトは、シートに浮かんで要るようなもので、EXCELのシートのセルとは何の関係もないものです。すなわちセルの属性ではない。 しかしそれでは不便な場合もあるので、 Sub test01() MsgBox ActiveSheet.Shapes.Count MsgBox ActiveSheet.Shapes(1).Name MsgBox ActiveSheet.Shapes(1).TopLeftCell.Address MsgBox ActiveSheet.Shapes(1).BottomRightCell.Address MsgBox ActiveSheet.Shapes(1).BottomRightCell.Column End Sub をやるとわかるように、位置関係について、オブジェクト側から TopLeftCell、BottomRightCellの属性を使えるようになっている。 ほかに「オートシェイプの書式設定」の「プロパティ」の「セルにあわせて・・」のような仕組みがあるだけである。 ーー だから、質問の、「範囲指定の仕方と言っても、TopLeftCell等の番地が、質問者の考える範囲内にある（InterSectする）か聞くほかない。 これもオブジェクトの位置を動かすと変わる不安定なものである。 ーー InterSectを使わないなら、ActiveSheet.Shapes(1).TopLeftCellなどのRowとColumnについて、列について２よりで大６より小、且つ行について3より大で８より小のような判別（IFで）プログラムでやることになる。 ーーー TopLeftCellとBottomRightCell のどちらを問題にするのか、両方を考えるかの問題は、当然ある。
お礼
お礼遅くなり申し訳ありません。 ありがとうございました。
- myRange
- ベストアンサー率71% (339/472)
＞範囲内のオートシェイプの数 この表現はちょっとあやふやです。 範囲に完全に入っているものの数か 範囲に少しでも入っているものの数か どちらでしょう。 で、２通り数えるコードを。。 '------------------------------------------ Sub Test() Dim Shp As Shape Dim Cnt1 As Long Dim Cnt2 As Long Dim myRange As Range Set myRange = Range("H1:J20") '●調査範囲、適宜に変更 For Each Shp In ActiveSheet.Shapes If Shp.Type = msoAutoShape Then '●範囲内に完全に入っているSHAPE If Not Intersect(Shp.TopLeftCell, myRange) Is Nothing And _ Not Intersect(Shp.BottomRightCell, myRange) Is Nothing Then Cnt1 = Cnt1 + 1 End If '●範囲内に一部でも入っているSHAPE If Not Intersect(Shp.TopLeftCell, myRange) Is Nothing Or _ Not Intersect(Shp.BottomRightCell, myRange) Is Nothing Then Cnt2 = Cnt2 + 1 End If End If Next Shp Range("I25").Value = Cnt1 Range("I26").Value = Cnt2 End Sub '----------------------------------------------- 以上です。
お礼
お礼遅くなり申し訳ありません。 ありがとうございました。
関連するQ&A
- オートシェープをグルーピングして動作させたい
office365 ２つのオートシェープをグルーピングして図形を動作させたい 下記で kibanは平行四辺形のオートシェープ yajirushiは右向き矢印のオートシェープ で、それぞれ、ある範囲で左から右に移動を繰り返します。 この２つのオートシェープをグルーピングして 平行四辺形の右側に矢印を配置した状態で、そのグルーピングされた図形の動作を繰り返す様にしたいのですが、 その内容が分からないのでコードで教えていただきたく、よろしくお願いします。 #If Win64 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else ' Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Sub kiban() shape_delete Dim ws2 As Worksheet Dim i As Integer Set ws2 = Sheets("sheet1") ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 354, 46, 20).Select With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 176, 80) .Transparency = 0 .Solid End With ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 458, 20, 20).Select ws2.Shapes(ws2.Shapes.Count).name = "kiban" For i = 0 To 30 If i = 30 Then i = 0 End If ws2.Shapes(1).Left = i * 3 + 365 ws2.Shapes(1).Top = 458 Sleep 100 DoEvents Next i ws2.Shapes("kiban").delete End Sub Sub yajirushi() shape_delete Dim ws As Worksheet Dim i As Integer Set ws = Sheets("sheet1") ws.Shapes.AddShape msoShapeRightArrow, 2265, 458, 20, 20 ws.Shapes(ws.Shapes.Count).name = "yajirushi" For i = 0 To 30 If i = 30 Then i = 0 End If ws.Shapes(1).Left = i * 3 + 420 ws.Shapes(1).Top = 458 Sleep 100 DoEvents Next i ws.Shapes("yajirushi").delete End Sub Sub shape_delete() Dim shp As Shape Dim rng As Range Range("P22:CM28").Select 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 shp.delete End If Next End Sub
- ベストアンサー
- Excel（エクセル）
- エクセルVBA オートシェイプを操作したいです
エクセルでセルの入力内容によって楕円をオートシェイプで出現させたいと思います。 http://oshiete1.goo.ne.jp/qa809742.htmlで見つかったものを参考にし、 Private Sub worksheet_Activate() Dim Shp As Shape Set P11 = Range("P11") If P11 Is Nothing Then Exit Sub If P11.Value = 1 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N14:N15") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left,TOP:=.TOP,Width:=.Width,Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N14").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp End If If P11.Value = 2 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N16") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left, TOP:=.TOP, Width:=.Width, Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N16").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp End If End Sub とつなげて見ました。 動くには動くのですが、データ元のセルがP11からT30と100セルあり、さらにP11に入力されるデータが１，２，３，４の4種類、AQ11に５，６，７，８，９の5種類などと、ばらばらです。 P11に１が入力されるとN14:N15(結合されています)に円が入り、２が入力されるとN16に円が入る。 Q11に５が入力されるとR13に円が入り、６が入力されるとR14:R15に円が入る・・・・のようにしたいのです。 一生懸命、セルNo.を打ち込んでいたら、 「コンパイルエラー：プロシージャが大きすぎます」とエラーが出てしまいました。 ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。 どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。 お知恵を貸していただけないでしょうか。よろしくお願い致します。
- ベストアンサー
- その他MS Office製品
- 指定範囲のオートシェイプの削除
範囲指定した箇所のオートシェイプを削除したく、WEBで見つけた物に手を加えてみました。しかし、実行されるとシート内全てのオートシェイプが削除されてしまいます。 今削除したいのは、Range("B21:AA22")範囲内のものだけです。 正直なところ大半の意味も判らないまま触っているので、問題箇所の検討が付きません。 どの部分を修正するばいいのでしょうか？ また、何故ダメなのかも合せてご教示いただけたら幸いです。 宜しくお願い致します。 Dim myShp As Shape Dim myR As Range, SR As Range On Error Resume Next Set myR = Range("B21:AA22") If Err.Number <> 0 Then Exit Sub On Error GoTo 0 For Each myShp In ActiveSheet.Shapes Set SR = Range("B21:AA22") If Not Intersect(SR, myR) Is Nothing Then myShp.Delete End If Set SR = Nothing Next Set myR = Nothing
- ベストアンサー
- Visual Basic
- 図形オートシェイプ内のテキスト検索マクロ作成についての質問
VBS2年目のプログラマーです。 Excelで図形オートシェイプ内のテキストが検索できないので、 マクロを作成してみようと思いましたが2点問題が発生しましたので 解決方法または実現方法をご教授ねがいます。 （目標マクロ機能概要） (1)InputBoxで検索文字列を入力 (2)検索文字列と一致するテキストを持つ図形を選択 (3)検索文字列と一致する次の図形を検索するかをMsgboxから選択 (この時、一致する図形は選択されている状態であってほしい) (4)(3)で次の図形を検索しない、または図形をすべて検索するとマクロ終了 （問題) １．機能概要(2)の選択される図形が現在のExcel画面外にある場合、画面が移動しないため、どこに検索ヒットした図形があるか使用者がわからない ２．機能概要(3)で、Msgbox実行時に図形選択が表示されず現在どの図形を選択しているのか使用者がわからない 問題1は、autoshapeオブジェクトのtop,left属性などを 使うしかないのかなとぼんやり考えています。 以下、コードです。 お忙しいところ、申し訳ありませんが 以上、よろしくお願いします。 ************************** Sub GetShapesText() Dim wk_shp As Shape 'オートシェイプ格納変数 Dim wk_search_str As String '検索文字列変数 '*** 検索文字列入力処理 *** wk_search_str = InputBox("検索する図形オートシェイプのテキストを入力してください。", "オートシェイプ内テキスト検索") If (Len(wk_search_str) = 0) Then '検索文字列が未入力の場合は、マクロ終了 Exit Sub End If '*** オートシェイプ検索処理 *** For Each wk_shp In ActiveSheet.Shapes If InStr(wk_shp.Name, "Line") = 0 Then 'オートシェイプが線(Line)以外の場合のみ以下を処理 If (InStr(wk_shp.TextFrame.Characters.Text, wk_search_str) > 0) Then 'オートシェイプのテキストに検索文字列が含まれる場合のみ以下を処理 wk_shp.Select '検索ヒットしたオートシェイプを選択 wk_next_search_flg = MsgBox("次を検索しますか？", vbYesNo) If (wk_next_search_flg = 7) Then '次を検索しない場合は、検索を終了 Exit For End If End If End If Next End Sub **************************
- ベストアンサー
- Visual Basic
- 既存のエクセルマクロに命令文を追加
既存のマクロに別の命令文を追加する場合について質問です。 選択した範囲のオブジェクトを削除するマクロがあります。 下の命令文に 「シート2でも同じことをする（ただし選択範囲はC30からG33）」 を追加する場合には、どのように書けばいいのでしょうか？ Sheets("シート1").Select Range("A65:E365").Select Dim shp As Shape Dim rng_shp As Range 'セルが選択されていないときは終了 If TypeName(Selection) <> "Range" Then Exit Sub 'アクティブシートのすべての図形にループ処理 For Each shp In ActiveSheet.Shapes '図形の配置されているセル範囲をオブジェクト変数にセット Set rng_shp = Range(shp.TopLeftCell, shp.BottomRightCell) '図形の配置されているセル範囲と '選択されているセル範囲が重なっていれば図形を削除 If Not Intersect(rng_shp, Selection) Is Nothing Then shp.Delete End If Next Sheets("シート0").Select Range("A1").Select 同じものを上記命令文の下にコピーして選択シートと範囲を直すだけだと、 Dim shp As ShapeとDim rng_shp As Rangeがエラーになります。 どなたかご教示お願いします。
- 締切済み
- その他（ビジネス・キャリア）
- エクセルＶＢＡでオートシェープを識別して削除したいのです・・・
エクセルシートにたくさん貼り付けた画像を一度に削除するため、下記のようなマクロを作成しました。 しかし、これでは「テキストボックス」や「→」のようなオートシェープも全部消えてしまいます。 画像データ（図）だけを認識して消すにはどうすればよいのでしょうか？ Sub sakujo() Dim Myshape As Shape For Each Myshape In ActiveSheet.Shapes If Myshape.Type <> msoFormControl Then Myshape.Delete End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- 指定した範囲で0の行を削除するマクロ
以下のコードで7列目が0の行を削除するマクロを作ったのですが、 13行目以降を削除するように指定できますでしょうか？ 1-12行は別のシートに数式を入れているため、削除したくないのですが、 うまくいきません。よろしくお願いいたします。 Sub 行削除() Dim Rw As Long Dim Cnt As Long Application.ScreenUpdating = False For Rw = Cells(Rows.Count, 7).End(xlUp).Row To 1 Step -1 With Cells(Rw, 7) If .Value = 0 Then .EntireRow.Delete Cnt = Cnt + 1 End If End With Next If Cnt = 0 Then MsgBox "削除対象行は、見つかりません。", vbExclamation Else MsgBox Cnt & " 件見つかり行を削除しました。", vbInformation End If End Sub
- ベストアンサー
- その他MS Office製品
- ExcelVBAでのオートシェイプ選択について
if オートシェイプ選択中 then 処理 end if このような事を考えているのですが、 オートシェイプを選択中という書き方がわかりません。 よろしくお願いします。
- ベストアンサー
- その他MS Office製品
- 範囲内の同名オブジェクトの削除
任意の範囲にあるオートシェイプを削除しようとして、調べて見たところ下記のような例文がありました。 Dim Obj As Object Dim MyR As Range, CkR As Range Dim M_Range As Range For Each Obj In ActiveSheet.DrawingObjects Set MyR = Range(Obj.TopLeftCell, Obj.BottomRightCell) Set CkR = Intersect(MyR, Range("B25:CN27")) If Not CkR Is Nothing Then If CkR.Count = MyR.Count Then Obj.Delete End If Set CkR = Nothing End If Set MyR = Nothing Next これだと通常に貼り付けたシェイプは削除出来るのですが、やろうとしているシートにはグループ化したシェイプを複数コピーして貼り付けてあります。 その為だと思うのですが、上記の方法だと削除出来ません。 原因は名前が同じなのでObj.Deleteが実行できないのだと思います。 同名のオブジェクトがある場合削除する方法はあるのでしょうか？ 実行したいのはシートの一部の範囲内だけです。 宜しくお願い致します。 尚、マクロの記録で行うと以下の様な状態です。 ActiveSheet.Shapes.Range(Array("グループ化 16", "グループ化 16", ・・・・)).Select Selection.Delete
- ベストアンサー
- Visual Basic
- フォームボタンを残して画像を消したい
マクロ初心者です。こちらではいつもお世話になっております。 現在、以下のような構文で、ある特定のセル（ここではB1セル）にかかっている画像を消すというマクロを組んでいます。 Sub 画像を消す() Dim shp As Shape For Each shp In ActiveSheet.Shapes If shp.TopLeftCell.Address = "$B$1" Then shp.Delete End Sub これで画像は消えるのですが、同時にこのマクロを実行するために設定してあるフォームボタンまで一緒に消えてしまうので困っています。 B1セルにボタンの一部がはみ出しているためですが、このボタンをB1セルにかからないように縮小すると使いづらいので、 何とか今のはみ出したままでも使えるようにしたいです。 フォームボタンのみを残して画像を消すには、どのような構文に変えればよいのでしょうか？ お知恵をお貸しいただければ幸いです。よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
お礼
お礼遅くなり申し訳ありません。 ありがとうございました。