• ベストアンサー

エクセルＶＢＡでオートシェープを識別して削除したいのです・・・

エクセルシートにたくさん貼り付けた画像を一度に削除するため、下記のようなマクロを作成しました。 しかし、これでは「テキストボックス」や「→」のようなオートシェープも全部消えてしまいます。 画像データ（図）だけを認識して消すにはどうすればよいのでしょうか？ Sub sakujo() Dim Myshape As Shape For Each Myshape In ActiveSheet.Shapes If Myshape.Type <> msoFormControl Then Myshape.Delete End If Next End Sub

質問者が選んだベストアンサー

  • ベストアンサー
回答No.2

No1の補足を見ました。 ひょっとして元の画像にリンクを張っていませんか？ もしそうなら、 msoPictureではなく、msoLinkedPictureです。

error123
質問者

お礼

そのとおりです。リンクを貼っていました。 解決しました！ ありがとうございました！

その他の回答 (1)

  • popesyu
  • ベストアンサー率36% (1782/4883)
回答No.1

画像データというのが具体的に何を示しているのか不明瞭ですが。 MsoShapeType の定数は他に20個ぐらいあるようで、この中で画像データというとおそらくmsoPictureのことかと思います。 ということで If Myshape.Type <> msoFormControl Then ↓ If Myshape.Type = msoPicture Then これで解決するのではないかなと。

error123
質問者

補足

それもやってみました。でも消えませんでした。 画像とはJpegやGifの写真なんです。クリックするとたとえば「図　1」となっています。 よろしくお願いします。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • エクセル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.を打ち込んでいたら、 「コンパイルエラー：プロシージャが大きすぎます」とエラーが出てしまいました。 ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。 どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。 お知恵を貸していただけないでしょうか。よろしくお願い致します。

  • オートシェープをグルーピングして動作させたい

    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

  • 指定範囲内のオートシェイプを数えるには？

    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 このマクロのどこにどう入れればよいでしょうか？

  • ＶＢＡ　図形の削除

    以下のようなコードにおいて、図名を指定するのではなく、図の種類を指定して削除したいのです。 テキストボックスを消す グラフを消す オートシェイプを消す などなど、オブジェクトの種類を指定して消すようにしたいのですが、どうすれば良いですか？ Sub 指定図形削除() 　図名＝”削除したい図形名” 　For Each zu In ActiveSheet.Shapes 　　If zu.Name = 図名 Then 　　　zu.Delete 　　　Exit　For 　　End If 　Next End Sub

  • エクセルのオートシェープ削除について

    セルＥ９：Ｊ９までに斜めの斜線を引いて、削除するマクロを 初心者なりに作成しました。 斜線作成は以下のような感じです。 Set myRng = Range("E9:J9") For Each sp In ActiveSheet.Shapes If Not Intersect(Range(sp.TopLeftCell,sp.BottomRightCell), myRng) Is Nothing Then sp.Delete End If Next Set myRng = Nothing で、フォームのボタンに登録させて罫線作ります。 ついでにリドゥボタン（戻る）も作成してやってみたのですが 以下のような感じで Set myRng = Range("E9:J9") For Each sp In ActiveSheet.Shapes If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then sp.Delete End If Next Set myRng = Nothing ですが、Ｌ９にリスト表示（入力規則のリストを設定）させたら If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then のところで1004エラーがでます。 リストはどうしても使用しなければならないので、どうしたらよいか？ どなたか詳しい方おられましたら、ご指導おねがいします。

  • VBAでオートシェイプの制御？

    エクセルマクロでセルにオートシェイプを張る方法を調べていて、ここで丁度いいのを見つけました。 http://oshiete1.goo.ne.jp/kotaeru.php3?q=808898 見つけた下記のマクロを実際にやってみました。 A1に１を入れるとB2にハートマークが出ます。 しかし、さらに２を入力してもB2のハートは削除されてくれません。 さらに１をいれると、ハートの上にハートが重なってしまいます。 １ならハート、それ以外の入力ならハートが消えるようにするにはどうすればいいのでしょうか？ Private Sub Worksheet_Change(ByVal Target As Range) If Target <> Range("A1") Then Exit Sub If Target.Value = 1 Then With ActiveSheet.Range("B2") ActiveSheet.Shapes.AddShape(Type:=msoShapeHeart, _ Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select End With End If 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

  • 指定範囲のオートシェイプの削除

    範囲指定した箇所のオートシェイプを削除したく、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

  • エクセルVBAでオートシェープを円く動かしたい。

    星型をシート上で回転しながらぐるっと円周のように動かそうと、ためしに下記のマクロを書きましたが、やはり方向転換がぎこちなく、スムーズな丸い動きにはなりません。 かと言って、上下左右以外に動かす方法はないでしょうし、何かいいやり方はないでしょうか？ Sub Star() With ActiveSheet.Shapes.AddShape(msoShape5pointStar, 273#, 43#, 50#, 50#) .Fill.ForeColor.SchemeColor = 13 .Line.Weight = 0.75 .Line.ForeColor.SchemeColor = 64 For i = 1 To 180 a = 1 b = 1 If i > 90 Then a = -1 If i < 45 Or i > 135 Then b = -1 .IncrementRotation 2 .IncrementTop 2 * a .IncrementLeft -2 * b DoEvents Next End With End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する