同名オブジェクトの削除方法
- 範囲内の同名オブジェクトを削除しようとしていますが、オートシェイプの削除方法ではうまくいきません。
- シートにグループ化したシェイプがあり、同名のオブジェクトを削除する方法を知りたいです。
- マクロを使って削除すると、オブジェクトを選択して削除する記録が残るため、より効果的な方法を探しています。
- ベストアンサー
範囲内の同名オブジェクトの削除
任意の範囲にあるオートシェイプを削除しようとして、調べて見たところ下記のような例文がありました。 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
- ae-1sp
- お礼率75% (92/122)
- Visual Basic
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
DrawingObjectsでは無く Shapesコレクションを For Eachでまわしてやればいいのでは ・・・
関連するQ&A
- 指定範囲のオートシェイプの削除
範囲指定した箇所のオートシェイプを削除したく、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
- マクロエラー 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
- 締切済み
- Visual Basic
- 特定文字列を含む行を削除するマクロ
すみませんどなたか教えてください。 エクセルで商品の在庫管理をしておりまして、AP列に製品メーカー名が入っているのですが、 いくつかの（数十個）メーカーを省き削除したく思い、以下のようなマクロをググって作ってみましたが、 上手く動きませんでした。 1つのメーカーだけ記載した場合はうまく動きました。 やりたいことは1つのマクロの中に、数十個のメーカー名を記入しておき、そのメーカーを全件 検索して、AP列に文字列が含まれる場合は、その行を削除したいです。 宜しくお願い致します。 ～～～～～～ Sub DelLines1() Dim R As Range Do Set R = ActiveSheet.Range("AP:AP").Find(What:="softbank", LookAt:=xlPart) If R Is Nothing Then Exit Sub R.EntireRow.Delete Loop Sub DelLines2() Dim R As Range Do Set R = ActiveSheet.Range("AP:AP").Find(What:="docomo", LookAt:=xlPart) If R Is Nothing Then Exit Sub R.EntireRow.Delete Loop Sub DelLines3() Dim R As Range Do Set R = ActiveSheet.Range("AP:AP").Find(What:="au", LookAt:=xlPart) If R Is Nothing Then Exit Sub R.EntireRow.Delete Loop End Sub
- ベストアンサー
- Excel（エクセル）
- 行の削除
列Ｋに、削除という文字が入っている場合は、その行を削除するということで、3000行くらいあるなかで3分の2程度は削除する行に該当します。 下のマクロで試してみましたが、このマクロではとっても時間がかかってしまうんですが、どうしたら早く処理できるのか教えて下さい。 Dim R As Range Do Set R = ActiveSheet.Range("K:K").Find(What:="削除", LookAt:=xlWhole) If R Is Nothing Then Exit Sub R.EntireRow.Delete Loop
- 締切済み
- その他(ソフトウェア)
- Excel VBAでの図形削除について質問です。
Excel VBAでの図形削除について質問です。 ボタンをクリックすると、ラインを使って、直角三角形を作成できる様にしました。 その際に、画像を全て削除してから作成する様にしました。 しかし、コマンドボタンまで消えてしまい困っています。 Dim MyLine As Shape Dim rngStart As Range, rngEnd As Range Dim BX As Double, BY As Double, EX As Double, EY As Double Dim dellShape As Object Set dellShape = ActiveSheet dellShape.Shapes.SelectAll 'すべての図形を選択する Selection.Delete '現在選択されているオブジェクトを削除する 'Shapeを配置するための基準となるセル Set rngStart = Range("C30") Set rngEnd = Range("J11") 'セルのLeft、Top、Widthプロパティーを利用して位置決め BX = rngStart.Left BY = rngStart.Top EX = BX + 300 EY = BY + 0 'Shapeの描画 Set MyLine = ActiveSheet.Shapes.AddLine(BX, BY, EX, EY) '横幅 Set MyLine = ActiveSheet.Shapes.AddLine(EX, EY, EX, 200) '高さ Set MyLine = ActiveSheet.Shapes.AddLine(BX, BY, EX, 200) '斜辺 これで?削除?作図と出来るのですが、作図された図形をDeleteキーで手動で削除した後に、 もう一度コマンドボタンをクリックすると、コマンドボタンまで削除されてしまいます。 通常ではコマンドボタンは削除されないので、原因が解りません。 同じ経験をされた方や、ExcelVBAに詳しい方、アドバイスよろしくお願いいたします。
- ベストアンサー
- その他（プログラミング・開発）
- 特定文がある行を削除
特定分がある行を削除しようと思い、以下のように設定いたしました。 Sub DelLines() Dim R As Range Do Set R = ActiveSheet.Range("A:A").Find(What:="指定文", LookAt:=xlWhole) If R Is Nothing Then Exit Sub R.EntireRow.Delete Loop End Sub これを、全てのシートに適用するにはどのように書けばよろしいのでしょうか？
- ベストアンサー
- Excel（エクセル）
- エクセル 同じ内容行削除マクロ 2
シート1、シート2（基準）のB列を比較して同じ内容行を削除したいのですが、「栃木県3」と「＃栃木県3」を同じのもと考えて削除されてしまいます。 Sub 削除() Dim wh1 As Worksheet Dim wh2 As Worksheet Dim f As Range Dim wR As Integer Dim mR As Long Dim wStr As String ' Set wh1 = Worksheets("Sheet1") Set wh2 = Worksheets("Sheet2") wR = 0 With wh1 mR = .Cells(Rows.Count, "A").End(xlUp).Row For wR = mR To 1 Step -1 wStr = .Cells(wR, "B") Set f = wh2.Range("B1:B" & wh2.Cells(Rows.Count, "B").End(xlUp).Row).Find(wStr) If Not f Is Nothing Then .Rows(wR).Delete End If Next End With End Sub 解決策教えて下さい。
- ベストアンサー
- オフィス系ソフト
- VBA エラー
Sub 上下カット1() Dim MyR As Range, MyMax As Integer, MyMin As Integer Dim MX As Range, MN As Range With ActiveSheet MyMax = WorksheetFunction.Max(.Range("D15:P15")) MyMin = WorksheetFunction.Min(.Range("D15:P15")) For Each MyR In .Range("D15:P15") If MyR.Value = MyMax Then Set MX = MyR If MyR.Value = MyMin Then Set MN = MyR Next MX.Borders(xlDiagonalUp).LineStyle = xlContinuous MN.Borders(xlDiagonalUp).LineStyle = xlContinuous End With With ActiveSheet MyMax = WorksheetFunction.Max(.Range("D16:P16")) MyMin = WorksheetFunction.Min(.Range("D16:P16")) For Each MyR In .Range("D16:P16") If MyR.Value = MyMax Then Set MX = MyR If MyR.Value = MyMin Then Set MN = MyR Next MX.Borders(xlDiagonalUp).LineStyle = xlContinuous MN.Borders(xlDiagonalUp).LineStyle = xlContinuous End With End Sub を実行すると”オブジェクト変数またはWithブロック変数が設定されていません。”と出ます。 どうしたらいいですか？
- ベストアンサー
- Excel（エクセル）
- VBA エラー
Sub 上下カット1() Dim MyR As Range, MyMax As Integer, MyMin As Integer Dim MX As Range, MN As Range With ActiveSheet MyMax = WorksheetFunction.Max(.Range("D15:P15")) MyMin = WorksheetFunction.Min(.Range("D15:P15")) For Each MyR In .Range("D15:P15") If MyR.Value = MyMax Then Set MX = MyR If MyR.Value = MyMin Then Set MN = MyR Next MX.Borders(xlDiagonalUp).LineStyle = xlContinuous MN.Borders(xlDiagonalUp).LineStyle = xlContinuous End With With ActiveSheet MyMax = WorksheetFunction.Max(.Range("D16:P16")) MyMin = WorksheetFunction.Min(.Range("D16:P16")) For Each MyR In .Range("D16:P16") If MyR.Value = MyMax Then Set MX = MyR If MyR.Value = MyMin Then Set MN = MyR Next MX.Borders(xlDiagonalUp).LineStyle = xlContinuous MN.Borders(xlDiagonalUp).LineStyle = xlContinuous End With End Sub を実行すると、 MX.Borders(xlDiagonalUp).LineStyle = xlContinuous の部分にエラーがでます。 対処方法を教えてください。
- ベストアンサー
- Excel（エクセル）
- 図形のクリアができない。
指定範囲(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
- ベストアンサー
- Visual Basic
お礼
教えていただいた通りShapesコレクションを追加しましたが、Set MyR = Range(Obj.TopLeftCell, Obj.BottomRightCell) でエラーが出てしまいます。これはオブジェクト名が異なる場合でも同じエラーを吐きました。 そこでOn Error Resume Nextを追加する事により問題なく動作させる事が出来ました。 ありがとうございます。