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

前へ 次へ
このQ&Aのポイント
  • 指定範囲(I9:CW40)から図形(円・四角形)のクリアをするとエラーになってしまいます。
  • 終了をすればクリアはできるのですが。
  • 御教授願えませんでしようか？(尚四角形はセルの枠線上に貼り付けるようにしてあります。)
回答を見る
  • ベストアンサー

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

  • Rord
  • お礼率67% (25/37)

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

  • ベストアンサー
  • redfox63
  • ベストアンサー率71% (1325/1856)
回答No.1

当然の結果だと思います ForEachは Inに指定した コレクションが普遍であるとして動作します 削除を行いたいのであれば ShapesのCountプロパティを使ってループを組みます 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 　　　　sp.Delete 　　end if next といった具合に Shapesコレクションの末尾から削除するようにしましょう

Rord
質問者

お礼

　 おしゃるとおりだと思います。無事に解決できました。 やはり勉強不足は否めませんし冷静に考えればそうなんですけどご指摘のように自分で考えて修正できるように少しずつでもスキルアップしていきたいと思います。 本当にありがとうございます。

その他の回答 (1)

  • mitarashi
  • ベストアンサー率59% (574/965)
回答No.2

当方xl2010ですが、特にエラーも無く実行できました。 一般にFor Eachを用いて削除すると、内部の管理番号？の振り直しのためか、消し損じが出ることがありますが、今回若干の試験では、消し損じも確認できませんでした。 エラー発生時のShapeを確認し、何か特異点が無いか確認してはいかがでしょうか。

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

関連するQ&A

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

    　指定範囲(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

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

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

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

  • EXCEL2007 VBA グラフサイズ修正バグ？

    下記のようなグラフのサイズ調整するVBAプログラムをEXCEL２００７で動かしました。 VBEで実行すると正常に動作します。 シートに図形を設置し、その図形にマクロを登録して実行すると、 グラフが3画面位広がってしまいます。 図形にマクロ登録してグラフ調整を正常に動かすことはできないのでしょうか? ----------------------------------------------------- 'グラフの再調整を行うサブルーチン Sub chartRerange() 　Dim wb As Workbook 　Dim strWbName As String 　Dim myRng1, myRng2, myRng3 As Range 　Dim myChart As Shape 　Dim rngTarget As Range 　 　 　'開いているすべてのワークブックを処理対象とする 　For Each wb In Workbooks 　　strWbName = wb.Name 　　 　　'「月度」が含まれているならば処理 　　If InStr(strWbName, "月度") <> 0 Then 　　　Set myRng1 = wb.Worksheets(2) 　　　Set myRng2 = wb.Worksheets(3) 　　　 　　　For Each myChart In myRng1.Shapes 　　　　'グラフならば 　　　　If (TypeOf myChart.OLEFormat.Object Is ChartObject) Then 　　　　　 　　　　　Select Case myChart.Name 　　　　　　Case "chart1" 　　　　　　　Set rngTarget = Range("B24:AG42") 　　　　　End Select 　　　　　　 　　　　　'グラフを指定したエリアに配置する 　　　　　With myChart 　　　　　　　.Top = rngTarget.Top 　　　　　　　.Left = rngTarget.Left 　　　　　　　.Width = rngTarget.Width 　　　　　　　.Height = rngTarget.Height 　　　　　End With 　　　　End If 　　　Next 　　End If 　Next 　　 　　MsgBox "処理完了" 　　 　　Set wb = Nothing 　　Set myRng1 = Nothing 　　Set myRng2 = Nothing 　　Set myChart = Nothing 　　Set rngTarget = 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

  • ExcelVBAで実行時エラーが出ます

    このようなマクロを作りました。 Sub WriteCsv() Dim myTxtFile As String, myFNo As Integer Dim myLastRow As Long, i As Long Dim j As Long Dim aaa As Worksheet Set aaa = ActiveSheet Application.ScreenUpdating = False j = 0 myTxtFile = ActiveWorkbook.Path & "\Adress List.txt" Worksheets("List").Activate myLastRow = Range("A4").End(xlDown).Row myFNo = FreeFile Open myTxtFile For Output As #myFNo　－－－－－※ For i = 4 To myLastRow If Cells(i, 3) = 1 Then Write #myFNo, Cells(i, 5) j = j + 1 End If Next Close #myFNo 　　・・・・ 　　・・・・ このExcelをフォルダーから実行するとすると、※で[ランタイムエラー５２]が発生しますが、デスクトップから実行すると出ません。 どのように修正すればいいんでしょうか？ よろしくお願いします。

  • VBAのファインドメソッドで検索すると対象外のデータが選択されることがある

    CDのリスト表（12列で、現在2269行 範囲名"収録表"）Sheets("データ")から,キーワードで該当ディスクを検索し、 結果をSheets("検索")に転記する、プログラムを作りましたが、 仮に、該当データが10件、転記されたとして そのデータを見ると、中に1件、対象外のデータがはいっている事が たまにあります、いろんな原因を考えてみましたがわかりません。 もともと、VBAのファインドメソッドが、こんなエラーを起こしやすいのか、、、（そんな事、ないよね） どなたか、教えてください。 下が、プログラムです Sub 新規検索() Application.ScreenUpdating = False Dim myData, myRng As Range Dim myWord As String myWord = InputBox("キーワードを入力してください") データ処理中F.Show vbModeless データ処理中F.Repaint Set myData = Range("収録表") Set myRng = myData.Find(What:=myWord, LookIn:=xlValues, _ Lookat:=xlPart, MatchCase:=False, MatchByte:=False) If myWord = "" Then MsgBox ("キーワードを入力してください") Exit Sub End If If Not myRng Is Nothing Then Application.Goto Cells(myRng.Row, 1), True Else: Unload データ処理中F MsgBox ("該当データはありません") Exit Sub End If Sheets("検索").Range("K1") = myRng.Row '一番最初の検索値のRow Call コピー1 Do Until Range("K1") = Range("L1") 　 Call 次を検索 Loop Call 検索終了 Unload データ処理中F Application.ScreenUpdating = True End Sub Sub 次を検索() Dim myData, myRng As Range Sheets("データ").Select Set myData = Range("収録表") Set myRng = Cells.FindNext(after:=ActiveCell.Offset(1)) If myRng <> "" Then Application.Goto Cells(myRng.Row, 1), True End If Sheets("検索").Range("L1") = myRng.Row '2番目以降の検索値のRow 　 Call コピー2 End Sub Sub コピー1() Sheets("検索").Range("A3:L5000,L1").ClearContents Dim myData As Range Set myData = Range("収録表") Set motorng = Application.Intersect(myData, ActiveCell.EntireRow) Set sakiRng = Sheets("検索").Range("A65535").End(xlUp).Offset(1) motorng.Copy sakiRng Sheets("検索").Visible = True Sheets("検索").Activate End Sub Sub コピー2() Dim myData As Range Set myData = Range("収録表") Set motorng = Application.Intersect(myData,　　　ActiveCell.EntireRow) Set sakiRng = Sheets("検索").Range("A65535").End(xlUp).Offset(1) motorng.Copy sakiRng Sheets("検索").Visible = True Sheets("検索").Activate End Sub Sub 検索終了() Dim r As Long r = Range("A65536").End(xlUp).Row Range("A" & r).Select ActiveCell.FormulaR1C1 = "=COUNTA(R3C:R[-1]C)" MsgBox "全部で" & Range("A" & r).Value & "件ありました" Range("A65535").End(xlUp).EntireRow.ClearContents Call 行頭表示 End Sub

  • エクセルで複数のブックの一部を抽出する

    エクセルで複数のブックの一部をBOOK1に1行ずつコピーしたいんですが、いろいろ探して近いものは見つけたのですが、元になるブックの1部の列をコピーするブックの行にコピー出来ないでしょうか？ merlionXXさんのhttp://oshiete1.goo.ne.jp/qa4969413.htmlこれを参考にして作っているのですが、 課名D16 商品名B20:B39 枚数H20:H39 金額I20:I39 の部分をbook1に1件1行としてコピーしたいのですができますでしょうか？ もとのブックの行数は決まっています。 どうか力を貸してください。よろしくお願いします。 Sub test02() Dim MyFile As String, MyPath As String '変数宣言 Dim x As Long, y As Long Dim wb As Workbook, tb As Workbook Dim ka As String Dim sh1, sh2 Set tb = ThisWorkbook MyPath = tb.Path & "\" '自分のパスを取得 MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のエクセルファイル Application.ScreenUpdating = False '画面更新停止 Application.Calculation = xlCalculationManual '自動計算停止 Do While MyFile <> "" 'エクセルファイルがなくなるまで If MyFile <> tb.Name Then '自分以外のファイルを対象 Set wb = Workbooks.Open(MyPath & MyFile) '選択したファイルを開く With ActiveSheet ka = .Range("D16").Value '課名取得 x = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 sh1 = .Range("B20:B" & x).Value '商品名取得 sh2 = .Range("H20:I" & x).Value '数量＆金額取得 End With With tb.Sheets("Sheet1") y = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 y = IIf(.Range("B" & y) = "", y, y + 1) If x >= 20 Then '納品書B20以下にデータがあれば Set myRng = .Range("A" & y).Resize(x - 19, 1) myRng.Value = ka '課名転記 myRng.Offset(, 1).Value = sh1 '商品名転記 myRng.Offset(, 2).Resize(, 2).Value = sh2 '数量＆金額転記 End If End With wb.Close (False) '選択したファイルを閉じる End If MyFile = Dir() '次のファイルを検索 Loop '繰り返し Application.Calculation = xlCalculationAutomatic '自動計算停止解除 Application.ScreenUpdating = True '画面更新停止解除 Set tb = Nothing Set wb = Nothing Set myRng = Nothing End Sub

  • ブック全体の検索の次へは？

    ブック全体を検索するマクロ作ったのですが、 ブックの最初にあるものしか見つけられません。 見つかった時に、次の検索を行うにはどのようなＶＢＡになるのでしょうか？ よろしくお願いもうしあげます。 Sub KensakuAll() 'ブック内の全シートを検索 　　Dim myWb As Workbook 　　Dim mySht As Worksheet 　　Dim myRng As Range 　　Dim Key1 As String 　　Key1 = InputBox("検索キーを入力しなさい") 　　If Key1 = "" Then Exit Sub 　　For Each mySht In Sheets 　　　　Set myRng = mySht.Cells.Find(what:=Key1) 　　　　If Not myRng Is Nothing Then 　　　　　　mySht.Activate 　　　　　　myRng.Activate 　　　　　　Set mySht = Nothing 　　　　　　Set myRng = Nothing 　　　　　　Exit Sub 　　　　End If 　　Next 　　MsgBox "該当するセルは見つかりませんでした" 　　Set mySht = Nothing 　　Set myRng = Nothing End Sub

  • エクセルＶＢＡの実行スピードが落ちます

    エクセルで検索を行うＶＢＡを使用していますが、エクセル立ち上げ時はサクサク動きますが、検索を繰り返し使っていくと、実行速度が落ちてしまいます。 エクセルを再起動すれば、元どおりの速さに戻ります。 何が原因でしょうか？どうすれば防ぐことはできるでしょうか？ よろしくお願い申し上げます。 実行環境 WindowsXPproSP3 Pen4 3.0Ghz メモリ1GB HDD80GB Office2003 ＶＢＡの検索部分 Function Kensaku3(Key1 As String, Range1 As String) As Long '縦方向の検索 　　Dim myRng As Range 　　Dim Job1 As String 　　Dim Col1 As Long 　　Dim Row1 As Long 　　Col1 = Range(Range1).Column 　　Row1 = Range(Range1).row 　　Cells(Row1, Col1).Select 　　Set myRng = Range(Range1).Find(what:=Key1, _ 　　　　After:=ActiveCell, LookIn:=xlValues, _ 　　　　LookAt:=xlPart, SearchOrder:=xlByRows, _ 　　　　SearchDirection:=xlNext, MatchCase:=False) 　　If myRng Is Nothing Then 　　　　Kensaku3 = 0 　　Else 　　　　Kensaku3 = myRng.row 　　End If 　　Set myRng = Nothing End Function

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する