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

前へ 次へ
このQ&Aのポイント
  • エクセルのオートシェープ削除について、初心者が作成したマクロに関しての質問です。
  • マクロを使用してセルＥ９：Ｊ９までに引かれた斜めの斜線を削除する方法を教えてください。
  • リドゥボタン（戻る）を作成してセルＥ９：Ｊ９の斜線を削除しようとした際に、リストを使用すると1004エラーが発生します。解決策を教えてください。
回答を見る
  • ベストアンサー

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

セルＥ９：Ｊ９までに斜めの斜線を引いて、削除するマクロを 初心者なりに作成しました。 斜線作成は以下のような感じです。 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エラーがでます。 リストはどうしても使用しなければならないので、どうしたらよいか？ どなたか詳しい方おられましたら、ご指導おねがいします。

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

  • ベストアンサー
  • merlionXX
  • ベストアンサー率48% (1930/4007)
回答No.1

入力規則のリストもShapeだからそうなるんでしょう。 以下のようにしたらどうでしょうか？ Set myRng = Range("E9:J9") For Each sp In ActiveSheet.Shapes If InStr(sp.Name, "Drop Down") = 0 Then If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then sp.Delete End If End If Next Set myRng = Nothing

takajin831
質問者

お礼

なるほど、Shapeだったのですね。 勉強不足です＾＾； 問題なく作動しました。ありがとうございました。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. その他（プログラミング・開発）

関連するQ&A

  • 図形のクリアで入力規則の▼が消える

    　図形のクリアで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

  • 図形のクリアができない。

    　指定範囲(I9:CW40)から図形(円・四角形)のクリアをするとエラーになってしまいます。御教授願えませんでしようか？(尚四角形はセルの枠線上に貼り付けるようにしてあります。) Sub 図形のクリア() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim myRng As Range Set myRng = Range("I9:CW40") 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 Then(ここで、1004の実行エラーになる。) sp.Delete End If Next Set myRng = Nothing Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

  • 図形のクリアで実行時の1004エラーになる

    　指定範囲(I9:CW40)から図形(円・四角形)のクリアをするとエラーになってしまいます。終了をすればクリアはできるのですが。御教授願えませんでしようか？(尚四角形はセルの枠線上に貼り付けるようにしてあります。) Sub 図形のクリア() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim myRng As Range Dim sp As Variant Set myRng = Range("I9:CW40") For Each sp In ActiveSheet.Shapes If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then sp.Delete　(ここで実行時1004のエラーになる。) End If Next Set myRng = Nothing Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

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

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

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

  • やはり図形のクリアで実行時エラー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

  • 範囲内の同名オブジェクトの削除

    任意の範囲にあるオートシェイプを削除しようとして、調べて見たところ下記のような例文がありました。 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

  • ExcelVBA With～End With構文でまとめられない？？

    すみませんがご教示いただければ幸いです。 セル範囲を選択させ、情報を得てから作業するのですが、コードにたくさんSelection（すべて同じ選択範囲）が出てくるのでWith～End Withでまとめようと思いました。 ところが、まとめてもSelectionという表記を省略できたのはほんのわずかです。 ご覧の通り、TypeName(Selection) をはじめIntersect(Selection(1), 等々省略できないのがほとんどです。 Set myRng=Selection でやったとしても、SelectionがｍｙRngに変わるだけでぜんぜん省略にならないですよね？ こんな場合は何か別の省略した書き方があるのでしょうか？ Sub test() With Selection If TypeName(Selection) <> "Range" Then 'セル以外をセレクトしてたら MsgBox "セル範囲を選択してください。", vbCritical, " Σ（￣ロ￣lll)" Exit Sub End If If Intersect(Selection(1), Range("D4:AY65")) Is Nothing _ Or Intersect(Selection(.Count), Range("D4:AY65")) Is Nothing Then '指定のセル範囲をはみ出てたら ans = MsgBox("はみ出してますがいいんですか？", vbYesNo + vbQuestion, " （￣□￣; ？ ") If ans = vbNo Then Exit Sub End If End If For Each Ln In ActiveSheet.Lines '配置された各直線につき If Not Intersect(Range(Ln.TopLeftCell, Ln.BottomRightCell.Offset(0, -1)), Selection) Is Nothing Then '選択範囲とかぶってたら MsgBox "重複してます！", vbCritical, " （￣□￣；）！！ " Exit Sub End If Next End With '以下、無関係なので略します。 End Sub

  • マクロエラー　1004　1004 アプリケーション定義またはオブジェクト定義のエラーです。

    下記のプログラムで 自分のパソコンでは正常に動くのですが 違うパソコンでは エラー1004、アプリケーション定義またはオブジェクト定義のエラーと出てしまいます。 セルの書式設定　→　表示形式　 を変更するとエラーがでてしまいます。 自分のパソコンでは何をしてもエラーは出ません。 エラーの対処の仕方を調べたのですがわかりませんでした。 教えていただけるとありがたいです。 以下作ったプログラムです。 Private Sub CommandButton2_Click() Dim myShp As Shape Dim myR As Range, SR As Range On Error Resume Next Set myR = Range("G87:K96") If Err.Number <> 0 Then Exit Sub On Error GoTo 0 For Each myShp In ActiveSheet.Shapes Set SR = Range(myShp.TopLeftCell, myShp.BottomRightCell) If Not Intersect(SR, myR) Is Nothing Then myShp.Delete End If Set SR = Nothing Next Set myR = Nothing End Sub

  • VBAでオートフィルを使って指定する文字列を含むものを表示させたい

    VBAを使って、セルD1に入力した文字列を検索するマクロを作りたいと思っています。 私は初心者で前に似たようなものを作ってもらって それを加工しようとしたのですが、うまくいきませんでした。 以前は完全に一致するもので表示でしたが、 今回は含むものを表示させたいです。 ワイルドカードは＊をつけるのはわかるのですが、 いろいろやってみましたがダメでした。（単純なことかもしれないですけど） Private Sub Worksheet_Change(ByVal Target As Range) Dim myRng1 As Range Dim myRng2 As Range Set myRng1 = Target.Cells(1) If Application.Intersect(myRng1, Range("D1")) Is Nothing Then Exit Sub Set myRng2 = Range("D1").CurrentRegion With myRng2 If myRng1 = "" Then ActiveSheet.ShowAllData Else .AutoFilter Field:=4, Criteria1:=myRng1.Value End If End With End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する