• ベストアンサー

どうして、VBA動作後に固まるのですか?

Windows XP Home Edition Excel 2002 変更前は、全く問題なく動作しましたが、 下記のように1行だけ変更しただけで動作後に固まってしまいます。 このようなことは初めてなのですが、 何卒、ご教授お願い致します。 Sub 動作後に固まる() '注意 Dim c As Range Do Set c = Range("A:A").Find(what:="No 01", LookIn:=xlValues, lookat:=xlWhole) If c Is Nothing Then Exit Do 'c.Offset(-1, 0).Resize(3, 1).EntireRow.Delete '変更前 c.Offset(1, 0).FormulaR1C1 = "固まる" 'この1行だけこのように変更しただけです Loop End Sub

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

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

提示されたコードでは、同じセルを無限に「Find」し続けます。 「Do~Loop」を使っているということは、複数の「No 01」をFindしたいのでしょうか? それなら「FindNext」を使う必要があります。 その場合も気をつけないといけないのは、Find、FindNextは検索値を何度も巡回することです。最初見つけたアドレスと同じアドレスならLoopからExitするという条件が必要になります。 こちらを参考にしてください。 http://www.moug.net/tech/exvba/0050116.htm ちなみに変更前のコードが動いたのは、「Delete」によってFindしたセルがなくなり新しいセルを見つけ続けたからです。

oshietecho-dai
質問者

お礼

早速のご回答、誠に有難うございました。 勉強をおこたってました。 ほんのちょっとだけですが、解かってきたようです。 For Each ・・・ For r = 1 To x - 1 などと同じように、単純に解釈しておりました。 甘く見てました。 皆様が良回答でした。

その他の回答 (3)

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.4

>c.Offset(1, 0).FormulaR1C1 = "固まる" は動くようだが普通は使わないとおもう。 ちなみに Sub test01() Cells(1, 1).Formula = "固まる" End Sub は可能にようだ。 普通は Sub test01() Cells(1, 2).Value = "固まる" End Sub とするとおもうが。 ーーーー Sub 動作後に固まる() Dim c As Range Do Set c = Range("A:A").Find(what:="No 01", LookIn:=xlValues, lookat:=xlWhole) If c Is Nothing Then Exit Do MsgBox c.Address 'c.Offset(-1, 0).Resize(3, 1).EntireRow.Delete '変更前 c.Offset(1, 0).FormulaR1C1 = "固まる" 'この1行だけこのように変更しただけです Loop End Sub とMsgBox c.Addressを入れて実行すればわかるが、無限に繰り返す。 2番目のNo 01のセル位置を見つけるには、FindNextを使い After指定を適当に指定しないとダメのはず。 該当が2つ以上ありえる場合は、Findをループの中に入れることは普通無い。 Sub test02() Dim c As Range Set c = Range("A:A").Find(what:="No 01", LookIn:=xlValues, lookat:=xlWhole) If c Is Nothing Then Exit Sub MsgBox c.Address Set d = c Do 'c.Offset(-1, 0).Resize(3, 1).EntireRow.Delete '変更前 'c.Offset(1, 0).FormulaR1C1 = "固まる" 'この1行だけこのように変更しただけです Set d = Range("A:A").FindNext(after:=d) If d.Address = c.Address Then Exit Sub MsgBox d.Address Loop End Sub のようになるのではないかな。 全般的に、何がしたいのか、データの情況が質問に書いてなくて、質問が判りにくいので、見当はずれかも知れないが。

oshietecho-dai
質問者

お礼

早速の詳細なご回答、誠に有難うございました。 無限と有限なんですね。 皆様、良回答でした。

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.2

「固まる」という意味はどういう意味ですか? 無限ループが起きているということでしょうか? ご質問の最初のコードと、以下のように文字を入れることとは、コードの持つ役割として若干違います。 以下は、ヘルプを調べれば分かるコードですが、こんな風にしてみたらどうでしょう。 Sub FixedInfiniteLoop()   Dim c As Range   Dim FirstAdd As String   Set c = Range("A:A").Find(What:="No 01", LookIn:=xlValues, LookAt:=xlWhole)   If Not c Is Nothing Then     FirstAdd = c.Address     Do       c.Offset(1, 0).Value = "修正後"       Set c = Range("A:A").FindNext(c)       If c.Address = FirstAdd Then Exit Sub '文字に置く     Loop Until c Is Nothing   End If End Sub

oshietecho-dai
質問者

お礼

早速のご回答、誠に有難うございました。 >「固まる」という意味はどういう意味ですか? >無限ループが起きているということでしょうか? 申し訳ありませんでした。 ずっと動作中なんですね! 固まったにしてはどうもいつもと違うとは思っておりました。

  • osamuy
  • ベストアンサー率42% (1231/2878)
回答No.1

元のコードですと、Deleteにより必ずFind対象が無くなる事でループから抜けますが、変更後はFind対象が常に見つかるのでループから抜けることがないという、ロジックミスかと。 ループ脱出条件を見直してみては。

oshietecho-dai
質問者

お礼

早速のご回答、誠に有難うございました。 そもそも、当方にとっては、 元のコード自体が非常に難しく、理解できてませんでした。 皆様が良良回答でした。

関連するQ&A

  • エクセル VBA

    Dim h As Range If Application.CountIf(Range("p:p"), 5) = 0 Then Exit Sub Set h = Range("p:p").Find(what:=5, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlPrevious) Range(Range("p2"), h).EntireRow.Delete Shift:=xlShiftUp 上記のマクロは、「2行目から、P列の数値が5の最下の行までを削除する」という内容です。 この5の部分を、<0(0未満)に変えたいのですがわかりません。 どうぞ教えてください。

  • エクセルVBA 前回のご回答で質問です

    http://oshiete1.goo.ne.jp/qa3764996.html 前回上の質問をさせていただき、お二方から大変よいご回答をいただきました。 これを勉強したいと思い、読み取ろうとしたのですが、理解できないところがあり、日本語にすればどのようになるのかお教えいただきたいと思い、質問にまた参りました。分からないところは、下の全コード中の、 r.Offset(0, -1).Resize(1, 2).Interior.ColorIndex = trg.Interior.ColorIndex '    r.Offset(0, -1).Resize(1, 2).Font.ColorIndex = trg.Font.ColorIndex の部分です。OffsetとResizeでの行、列の方向性が理解できないのです。よろしければコメントを着けていただければ助かります。 よろしくお願いします。 Sub Macro1() Dim r, trg As Range  For Each r In Range("B4:AD27")   If r.Value <> "" Then    Set trg = Range("B1:O1").Find(what:=r.Value, LookIn:=xlValues, lookat:=xlWhole)    If Not trg Is Nothing Then     r.Offset(0, -1).Resize(1, 2).Interior.ColorIndex = trg.Interior.ColorIndex '    r.Offset(0, -1).Resize(1, 2).Font.ColorIndex = trg.Font.ColorIndex    End If   End If  Next r End Sub

  • エクセルVBA条件セル検索時連続時処理中止と列複数

    いつもお世話になっております。 Excel2013のVBAでまた質問があります。お願いいたします。 ある表のにある値が入力されていたら、その値をコピーして1行上の4列右の列に貼り付け、もとの行の値を削除するように色々参考にしながら作りました。 ある値を例えば、"AAA”と"BBB"だとして、下記コードでなんとか最初の段階が実現できました。 あと、やりたいのは、条件を検索する列の、"AAA"もしくは"BBB"の値が連続している場合は、メッセージを出して、処理を中止にしたいです。単体で連続でも2つの組み合わせでも、この2つのうちいずれかが入力されている行が続いていたら中止です。 あと、最初にWorksheets("Sheet1").UsedRange.Columns(5)列目を指定しているんですが、実際は、複数の列を指定したいです。コピーしたり消去したりのオフセットの位置関係は変わりません。 必要なら、名前を定義して、一括で指定するのも大丈夫です。 お手数をおかけしますが、ご教授よろしくお願いいたします。 Sub TEST() Dim c As Range Dim firstAddress As String ' ActiveSheet.UsedRange.Select With Worksheets("Sheet1").UsedRange.Columns(5) Set c = .Find(What:="AAA", _ LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do Range(c.Address, Range(c.Address).Offset(0, 1)).Copy Range(c.Address).Offset(-1, 4) Range(Range(c.Address).Offset(0, -1), Range(c.Address).Offset(0, 6)).ClearContents Set c = .FindNext(c) If c Is Nothing Then Exit Do Loop Until c.Address = firstAddress End If '別条件でもう一度 Set c = .Find(What:="BBB", _ LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then firstAddress = c.Address Do Range(c.Address, Range(c.Address).Offset(0, 1)).Copy Range(c.Address).Offset(-1, 4) Range(Range(c.Address).Offset(0, -1), Range(c.Address).Offset(0, 6)).ClearContents Set c = .FindNext(c) If c Is Nothing Then Exit Do Loop Until c.Address = firstAddress End If End With End Sub

  • エクセルのVBAで悩んでいます。

    いつもありがとうございます。 エクセルのVBAで悩んでいます。 セルの範囲指定をVBAで行いたいのです。 ただし、引数に数値変数を使用する為、Cellsプロパティを使います。 すると、離れている範囲の範囲指定が出来ないのです。 例えば、Rangeプロパティだと、 Range("A5:E5,A9:E32").Select こうなるところを、 A9:E32 を変数に置き換えたくて、 Range("A5:E5", Cells(g, 1), Cells(h, 5)).Select と、するとエラーが出ます。 VBAの前文は次の通りです。 Private Sub CommandButton1_Click() a = Me.TextBox1.Value b = Me.TextBox2.Value Set c = Range("a:a").Find(what:=a, LookIn:=xlValues, lookat:=xlWhole) Set d = Range("a:a").Find(what:=b, LookIn:=xlValues, lookat:=xlWhole) 'MsgBox c + d e = c.Address 'MsgBox e f = d.Address 'MsgBox f g = Range(e).Row MsgBox g h = Range(f).Row MsgBox h Range(Cells(g, 1), Cells(h, 5)).Select End sub よろしくお願い致します。

  • Excel:VBA-改行して同じ動作を繰り返すには

    VBAで下記の動作を実現させたいのですが、もう一歩のところで上手くいきません。 アドバイスを宜しくお願いします。 ・C列が空欄になるまで、AD列を改行させて同じ作業を繰り返す。 Do Loopステートメントで下記のように作ってみたのですが、"AD2"から"AD3"に改行させることが 出来ないのです。 ------------------------------------ Sub 棚番2() Range("C2").Activate Do Until ActiveCell.Value = "" Range("AD2").FormulaR1C1 = _ "=IF(ISERROR(VLOOKUP(RC[-27],棚番!C2:C3,2,0)),"""",VLOOKUP(RC[-27],棚番!   C2:C3,2,0))" Range("AD2").Copy Range("AD2").PasteSpecial Paste:=xlPasteValues ActiveCell.Offset(1).Activate Loop End Sub --------------------------------- 何卒アドバイスを下さいますよう宜しくお願いいたします。

  • マクロ 実行エラー1004

    エクセル2000を使用しています。 以下のマクロを作り、19行目の”AAA”を探し、29行目で1つ前の列までロックしようとしています。 新規のエクセルで使用すると、動作しますが、肝心の組み込みたいエクセルだと動作しません。 19行目には”AAA”以外の文字列があります。 (19行目には、”AAA”は必ず1つしかありません) また、”AAA”は関数で19行目に表示されています。 実行すると最後の行のRange(Range("A29"), h.Offset(1, -1)).Locked = Trueで黄色ハイライトされ 実行エラー1004で「RangeクラスのLockedプロパティを設定できません。」を表示されます。 何か対処するよい方法があれば、教えてください。 Private Sub Worksheet_Change(ByVal Target As Range) Dim h As Range Cells.Locked = False ActiveSheet.Protect userinterfaceonly:=True Set h = Range("19:1").Find(what:="AAA", LookIn:=xlValues, lookat:=xlWhole) If h Is Nothing Then Exit Sub If h.Column = 1 Then Exit Sub Range(Range("A29"), h.Offset(1, -1)).Locked = True End Sub

  • マクロがエラーになります。原因は?

    先日zap35さんにB1:O1に掲げる文字とそのセルの色と同じ ものをB4:AD27の範囲内で見つけてそのセルと、左のセルを 色づけする、というマクロを教わりました。(というより すべて教えてもらいました) コードは完璧で動いているのですが、私のほうでゴチャゴチャ いじっているうちに、B4:AD27の範囲の文字を関数により表示 するように変更しました。たぶんこのことが原因だと思うので すが、色がつかなくなりました。関数をはずして、文字として 打ち込むと、動作します。コードの一部を変更したりして関数でも 動作するようになるでしょうか? Sub Macro1() Dim r, trg As Range  For Each r In Range("B4:AD27")   If r.Value <> "" Then    Set trg = Range("B1:O1").Find(what:=r.Value, LookIn:=xlValues, lookat:=xlWhole)    If Not trg Is Nothing Then     r.Offset(0, -1).Resize(1, 2).Interior.ColorIndex = trg.Interior.ColorIndex '    r.Offset(0, -1).Resize(1, 2).Font.ColorIndex = trg.Font.ColorIndex    End If   End If  Next r End Sub

  • マクロのループが次へ進みません!!

    Sub 不要な行を削除() Dim fWord As String, fAdd, c, wb As Workbook fWord = "ああ"  '←"ああ"の行は複数あります '下記3行はなくてもよいかも。以前、あったほうがうまく実行できましたので。 Workbooks("てすと.xls").Activate Rows("1:1").Select Selection.Insert Shift:=xlDown With Workbooks("てすと.xls").Worksheets(1).Range("A:A") Set c = .Find(fWord, LookIn:=xlValues) If Not c Is Nothing Then fAdd = c.Address Do   c.Offset(-1, 0).EntireRow.Delete    c.Offset(-1, 0).EntireRow.Delete   c.Offset(0, 0).EntireRow.Delete   Set c = .FindNext(c)  '←ここからエラーとなってしまいます Loop While Not c Is Nothing And c.Address <> fAdd End If End With End Sub --- 「実行時エラー’1004’  Range クラスのFindNextプロパティを取得できません。」 とエラー表示されてしまいます。 --- 複数ある「"ああ"の行」の最上の1行だけにのみ実行されるだけです。 間違い箇所をご教示下さいませ。 よろしくお願い致します。

  • Excel VBAで表組みしたらデバック発生

    Excel VBAの初心者です。Windows Vistaで Excel2007を使っています。 表をマクロの実行で作成したいと思っています。 何もないエクセルブックより 「開発」→「マクロの記録」→「相対参照」 →「表の作成」→「記録終了」→「相対参照で記録の解除」 →「エクセルマクロ有効ブックで保存」 ところがこのマクロ記録が入ったブックを再度立ち上げ、 表をオールクリアにし、マクロボタンより表作成を実行 させようとすると、次のエラーメッセージがでました。 『実行時エラー'9' インデックスが有効範囲にありません。』 デバックからModule1をみると以下の記述となっていました。 Sub 表組み() ' ' 表組み Macro ' ' ActiveCell.Range("A1:E5").Select Selection.Copy Windows("Book1").Activate ActiveSheet.Paste ActiveCell.Columns("A:A").EntireColumn.Select ActiveCell.Rows("1:1").EntireRow.RowHeight = 11.25 ActiveCell.Rows("1:5").EntireRow.Select Selection.RowHeight = 21.75 ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 14.88 ActiveCell.Offset(0, 4).Range("A1").Select Application.CutCopyMode = False With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With ActiveCell.Offset(1, -3).Range("A1:D4").Select Selection.NumberFormatLocal = "#,##0_ " ActiveCell.Select ActiveCell.FormulaR1C1 = "78000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "102000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "9800" ActiveCell.Offset(-2, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "65000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "204000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "500" ActiveCell.Offset(-2, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "86000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "151000" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "10200" ActiveCell.Offset(-2, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(RC[-3]:RC[-1])" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(RC[-3]:RC[-1])" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)" ActiveCell.Offset(1, 0).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)" ActiveCell.Offset(0, -3).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)" ActiveCell.Offset(0, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)" ActiveCell.Offset(0, 1).Range("A1").Select ActiveCell.FormulaR1C1 = "=SUM(R[-3]C:R[-1]C)" ActiveCell.Offset(-4, -2).Range("A1:D1").Select Selection.AutoFilter End Sub 上から9行目(?)のWindows("Book1").Activateに 黄色い矢印が示され、また行全体が黄色く四角に 覆われていました。 おそらくこの記述に問題があると思いますが、 どんな記述に変えたらいいのか分かりません。 Excel VBAにお詳しい方ご教示願います。 なお、マクロで作成したい図を添付いたします。 参考にしていただければ幸いです。

  • マクロ セル情報を変数に代入するには?

    いつも回答して頂き、感謝しています。 FINDで抽出した作業状態のセル位置情報を起点にして、作業名の横のセル情報と作業箇所の横のセル情報を取得し、変数に代入したのですが、作業箇所の横のセル情報がどうしてもうまく代入されません。 オフセットの値が間違っているのではと思い、 Set res2 = res1.Offset(2, 0) → res1.Offset(2, 0).Selectと 変更し選択出来ているか確認しましたが、思った通りに選択出来ていました。 選択できているのに、どうしてセル情報が変数に代入できないのでしょうか?大変お手数だとは思いますが、御指導の程宜しくお願い致します。 Sub 作業状態のエリアを作業名別に各シートに貼り付ける() Dim c As Range Dim res1 As Range Dim res2 As Range Dim c0 As String With Worksheets("書面").Columns("B:D") Set c = .Find(what:="作業状態", LookIn:=xlValues, lookat:=xlWhole) If c Is Nothing Then Exit Sub c0 = c.Address Do Set res1 = c.Offset(0, 7) Set res2 = res1.Offset(2, 0) Application.Intersect(c.MergeArea.EntireRow, Range("B:BQ")).Select Set c = .FindNext(c) Loop Until c.Address = c0 End With End Sub

専門家に質問してみよう