- ベストアンサー
ＶＢＡ 図形の削除
以下のようなコードにおいて、図名を指定するのではなく、図の種類を指定して削除したいのです。 テキストボックスを消す グラフを消す オートシェイプを消す などなど、オブジェクトの種類を指定して消すようにしたいのですが、どうすれば良いですか？ Sub 指定図形削除() 図名＝”削除したい図形名” For Each zu In ActiveSheet.Shapes If zu.Name = 図名 Then zu.Delete Exit For End If Next End Sub
- VitaminBB
- お礼率95% (2783/2916)
- Visual Basic
- 回答数2
- ありがとう数3
- みんなの回答 （2）
- 専門家の回答
質問者が選んだベストアンサー
Type プロパティでオブジェクトが図形なら 図形の種類を長整数値で取得できます。 MsoShapeTypeクラスの下に定数があります。 例えば、テキストボックスならmsoTextBox(=17)、 オートシェイプならmsoAutoShape(=1)です。 テキストボックスだけを消したいのなら、 If zu.Type = msoTextBox Then で判定できると思います。
その他の回答 (1)
- imogasi
- ベストアンサー率27% (4737/17068)
この辺（ShapeかOLEObjectかDrawingObjectかControlなど）はバージョンアップともに進化しているところのように思いますが、諸書も体系的記述にでく合わさず、不勉強ですが、オブジェクトの捉え方について Sub test02() Dim oObj As Shape For Each oObj In ActiveSheet.Shapes MsgBox oObj.Type & "=" & oObj.Name next End Sub を実際のシートでやってみて、考えて見てください。 図形描画でも上記で１と９と出るものがあり、上記分類で ご質問のニーズに合うのか判りませんが。 ヘルプにShape、ShapeRange の定数の一覧（種類）が載っています。 Sub test03()() Dim oObj As Object For Each oObj In ActiveSheet.DrawingObjects MsgBox oObj.Name Next End Sub のNameでは駄目なわけですよね。
お礼
回答ありがとうございます。
関連するQ&A
- エクセルＶＢＡでオートシェープを識別して削除したいのです・・・
エクセルシートにたくさん貼り付けた画像を一度に削除するため、下記のようなマクロを作成しました。 しかし、これでは「テキストボックス」や「→」のようなオートシェープも全部消えてしまいます。 画像データ（図）だけを認識して消すにはどうすればよいのでしょうか？ Sub sakujo() Dim Myshape As Shape For Each Myshape In ActiveSheet.Shapes If Myshape.Type <> msoFormControl Then Myshape.Delete End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでAutoShape削除
シートからオートシェープの星型と線を削除するためのマクロですが、以下でうまく行きます。 Sub SAKUJO() For Each s In ActiveSheet.Shapes If s.Type = msoLine Or s.AutoShapeType = msoShape5pointStar Then s.Delete Next End Sub 質問は、線と星型を他のオートシェープと選別するために、線は「Type」、星型は「AutoShapeType」と異なる選別方法を別々に指定しなければならないのかということです。そもそも「Type」と「AutoShapeType」は何が違うのでしょう？ 両方を同じように「Type」か「AutoShapeType」あるいは他の方法で指定する方法はないのでしょうか？
- ベストアンサー
- オフィス系ソフト
- エクセル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製品
- Excelマクロ ○印図形を消したい
○印図形を消したい Private Sub CommandButton2_Click() ' ○印をつける Dim a As Range If TypeName(Selection) = "Range" Then Set a = Selection ActiveSheet.Shapes.AddShape(msoShapeOval, a.Left, _ a.Top, a.Width, a.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse a.Select End If End Sub Private Sub CommandButton3_Click() 上記のマクロでつけた○印を下記のようなマクロで（指定の範囲のセルにつけた○印を全て）消したいのですが、上記のマクロは問題なく動作するのですが、下記のマクロがうまく動きません、どこをどのように変更したらよいのでしょうか？、どなたかご教示ください。 ' 指定したセル範囲にある図形を削除する() ' ○印の削除 指定セル範囲 = "U32:X41" With ActiveSheet Set セル範囲 = .Range(指定セル範囲) For Each 図形 In .Shapes If 図形.Type = msomsoPicture Then Set 共有セル範囲 = Intersect(Range(図形.TopLeftCell, _ 図形.BottomRightCell), セル範囲) If Not (共有セル範囲 Is Nothing) Then 図形.Delete End If End If Next End With End Sub
- ベストアンサー
- その他MS Office製品
- VBAで同じ作業を２回繰り返す場合のコード
下記コードで具体的アドバイスを頂ければと思います。よろしくお願いいたします。 ■やりたいこと EXCELのシートに、２種類の写真表示スペースを作って、そのそばでそれぞれファイル名を入力して、そのファイル名を変えるごとに、それぞれのjpegファイルを表示させたい。 ■質問 下記コードで、ふたつめの変数を変えればよいことは、分かるのですが、どこをどのようにして、変数を変えればいいかわかりません。ご教授お願いします。 ■私の作っているコード とあるサイトを参考にして、下記作成いたしました。 'ひとつめ写真表示 Private Sub Worksheet_Change(ByVal Target As Range) Dim fName As String, pict As Shape If Target.Address <> "$H$25" Then Exit Sub fName = ThisWorkbook.Path & "\board_Image\" & Target.Offset(0, 0).Text If Dir(fName) = "" Then fName = ThisWorkbook.Path & "\board_Image\NoImage.jpg" End If With ActiveSheet For Each pict In .Shapes If pict.TopLeftCell.Address = "$C$26" Then pict.Delete Exit For End If Next pict Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _ .Range("k6").Left, .Range("C26").Top, 260, 320) End With End Sub ----------------------------------------------------------------------------- 'ふたつめ写真表示 Private Sub Worksheet_Change(ByVal Target As Range) Dim fName As String, pict As Shape If Target.Address <> "$AT$4" Then Exit Sub fName = ThisWorkbook.Path & "\map_Image\" & Target.Offset(0, 0).Text If Dir(fName) = "" Then fName = ThisWorkbook.Path & "\map_Image\NoImage.jpg" End If With ActiveSheet For Each pict In .Shapes If pict.TopLeftCell.Address = "$k$6" Then pict.Delete Exit For End If Next pict Set pict = .Shapes.AddPicture(fName, msoTrue, msoFalse, _ .Range("k6").Left, .Range("k6").Top, 260, 320) End With End Sub
- ベストアンサー
- オフィス系ソフト
- オートシェープをグルーピングして動作させたい
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（エクセル）
- シート上のjpg画像のみを一括削除したい
Excel VBA勉強中の者です。 早速ですが、シート上にあるjpg画像のみを一括削除したく ネットで調べつつ以下のコードを作ってみました Sub dlt() '既存の画像を削除 Dim jpgdlt As Shape With ActiveSheet .DrawingObjects.Delete 'このコードが違っている？？？ For Each jpgdlt In .Shapes ’For Each Next で選択対象を繰り返し削除 jpgdlt.Delete Next End With End Sub これでjpg画像の削除は出来たのですが、シート上に配置した コントロールなどのオブジェクトも全て削除されてしまい困っております。 以下のコードも作ってみたのですが、こちらはメモリーが不足しているという エラーを回避できず、オブジェクトが削除されるか検証する前に使用を断念しました。 Sub dlt() '既存の画像を削除 Dim jpgdlt As Object Set jpgdlt = ActiveSheet jpgdlt.Shapes.SelectAll Selection.Delete End Sub ｊｐｇ画像のみを選択し、削除するにはどうすれば宜しいのでしょうか？ 色々調べてはみたものの、自力での解決に至らず、 お手数お掛けしますがどなたかご助力お願い致します。
- ベストアンサー
- オフィス系ソフト
- ＶＢＡについて教えてください。
ＶＢＡについて質問です。 シート1（元払）があり、そのシート内のオートシェイプを消す式が下記の式で 可能なのですが、別シートのオートシェイプも同時に消す場合はどのようにすれば良いか 教えてください。 Sheets("元払").Select Dim sh As Shape For Each sh In ActiveSheet.Shapes If sh.Type = msoAutoShape Then sh.Delete End If Next sh
- ベストアンサー
- Visual Basic
- 図形のクリアで入力規則の▼が消える
図形のクリアでG1の入力規則の▼まで一時的に消えてしまいます。コード文でShapesを 用いているのではないかと思いますが、▼で消去を回避する方法が ありましたらお教え願え ますでしょうか？ Windows7・SP1 Office2010 Sub 図形のクリア() Dim myRng As Range Dim sp As Variant Set myRng = Range("I10:CW60") For Each sp In ActiveSheet.Shapes If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then On Error Resume Next sp.Delete End If Next Set myRng = Nothing End Sub
- ベストアンサー
- Visual Basic
- やはり図形のクリアで実行時エラー1004
図形を二行三列で一枡とし図形を貼り付けていますが、どうしても実行時エラー 「1004」が出て図形のクリアができません。(尚、四角形は枠線上にあります。) 対処法がありましたらお願いします。 Windows7・SP1 Office2010 Sub 図形の貼付け() Dim i As Integer Dim j As Integer For i = 10 To 43 Step 2 For j = 9 To 99 Step 3 Select Case Cells(i, j).Value Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 2: ActiveSheet.Shapes("四角形2").Select Selection.Copy Cells(i + 1, j).Select ActiveSheet.Paste Case 4: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 5: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 2).Select ActiveSheet.Paste Case 6: ActiveSheet.Shapes("円1").Select Selection.Copy Cells(i, j).Select ActiveSheet.Paste End Select Next Next End Select End Sub Sub 図形のクリア() Dim myRng As Range Set myRng = Range("I10:CW43") Dim n As Integer, sp As Variant For n = ActiveSheet.Shapes.Count To 1 Step -1 Set sp = ActiveSheet.Shapes(n) If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing (ここで実行時エラー1004になります。) Then sp.Delete End If Next Set myRng = Nothing End Sub
- ベストアンサー
- Visual Basic
お礼
回答ありがとうございます。