• 締切済み

VBA Do Until ~ Loop 内にif

Excel VBAマクロにて、C列のセルのうちOKと書かれたセルのみ塗りつぶすコードを作成したつもりなのですが、動いてくれません。エラー表示も出ません。間違いを指摘して下さる方、あるいは別の書き方があるという方、教えていただけないでしょうか。 下記私が作成したものです。C列にAと書かれたセルが現れるまで処理をするようにしています。 Sub sample() Dim i As Long i = 1 Do Until Cells(i, "C").Value = ”A" If Cells(i, "C").Value = "OK" Then Cells(i, "C").Interior.ColorIndex = 5 End If i = i + 1 Loop End Sub

みんなの回答

  • NuboChan
  • ベストアンサー率47% (746/1586)
回答No.6

sample、参考だけです。 Option Explicit Sub ColorCells() Dim cell As Range For Each cell In Range("C:C") If cell.Value = "OK" Then cell.Interior.ColorIndex = 5 '青色 End If Next End Sub Sub ColorCells2() 'ExcelのVBAマクロにて、C列のセルで文字列中にOKと言う文字列が含まれたセルのみ黄色で塗りつぶすコード Dim cell As Range For Each cell In Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row) If InStr(cell.Value, "OK") > 0 Then cell.Interior.ColorIndex = 6 End If Next cell End Sub Sub ColorCell3() 'ExcelのVBAマクロにて、C列のセルで文字列中にOK又はokと言う文字列が含まれたセルのみピンクで塗りつぶすコード Dim lastRow As Long Dim i As Long lastRow = Cells(Rows.Count, "C").End(xlUp).Row For i = 1 To lastRow If InStr(1, UCase(Cells(i, "C")), "OK") > 0 Then Cells(i, "C").Interior.ColorIndex = 7 'ピンク End If Next i End Sub

全文を見る
すると、全ての回答が全文表示されます。
  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.5

勉強のためなら、質問に目的をまず明記すべきだ。 例えば While文の使い方、 セルに条件で色を付ける、 ターゲットの値が同類が複数ある対処(OK,oKなど)など。 のどれかなどを。 小生なら、コード上で、繰り返しを極力少なくするコードの勉強をする。For Next、While、Loopuntil、If文、Case文などステートメントのブロックになるやり方は少なくする。 エクセルVBAなら機能(本件では条件付き書式)の勉強を中心にする。 内容は、セル集団に対しての繰り返しやIFの要素が背景にあるが、両者はコード上は隠されていてでてこない。これがアプリ(エクセルなど)のスクリプトの最大の利点です。 ーー 例えば、下記のようなのを考えてみた。 Sub test01() Set fnd = Range("A:A").Find("A") ’A列で、Aの値のセルを見つける If Not fnd Is Nothing Then   ’存在すれば Set fc = Range(Cells(1, "A"), fnd).FormatConditions.Add(xlCellValue, xlEqual, "OK") ’条件付き書式を設定 fc.Interior.ColorIndex = 5 End If End Sub 小生なら、ColorIndex = 5は、色が濃くて地が見えにくい。淡いyellowやpinkなどを考える。

全文を見る
すると、全ての回答が全文表示されます。
  • kkkkkm
  • ベストアンサー率65% (1624/2466)
回答No.4

No.2の追加です。 Aの所がおかしいと、最後にエラーになる(もしくは永遠に終わらない)と思いますので間違いは無いと思いますが、念のためにAのところもOKと同じように考えてください。

全文を見る
すると、全ての回答が全文表示されます。
  • kkkkkm
  • ベストアンサー率65% (1624/2466)
回答No.3

No.2の追加です。 もし、OKが含まれているでしたら以下で試してみてください。 If Trim(StrConv(Cells(i, "C").Value, vbNarrow Or vbUpperCase)) Like "*OK*" Then

全文を見る
すると、全ての回答が全文表示されます。
  • kkkkkm
  • ベストアンサー率65% (1624/2466)
回答No.2

セルにOKだけがありそれが半角でしたらセルの色は変わりました。 半角でもOkとかoKとかokだと駄目ですし、前後に空白スペースがあっても駄目です。 とりあえずコードに書かれているOKをC列のセルに入れて試してみて変わるようでしたら セルの値を「半角の大文字にし、前後のスペースを除いたもの」とOKを比較するようにした以下で試してみてください。 If Trim(StrConv(Cells(i, "C").Value, vbNarrow Or vbUpperCase)) = "OK" Then StrConvについては以下のサイトを参考にしてください。 VBA StrConv 関数:全角と半角を変換する https://www.tipsfound.com/vba/05strconv また、そのコードが、たとえばSheet1のシートモジュールに書かれていて、Sheet2を見ているのでしたらSheet2では何もおこりません。 標準モジュールに書かれていれば見ているシートが変化します。

全文を見る
すると、全ての回答が全文表示されます。
  • kon555
  • ベストアンサー率52% (1761/3379)
回答No.1

『動いてくれません。』とは具体的にはどのような挙動になりますか?  ループが終わらないのか、すぐに終了するのか、ループ自体は想定通り回っているけれどその先が処理されないのか、どれでしょうか。  まずはそれを切り分けましょう。  ステップインで1行ずつ確認し、『何が失敗しているのか』を明らかにしてみて下さい。 https://haginote.com/vba-step-in-over-out

全文を見る
すると、全ての回答が全文表示されます。

関連するQ&A

  • Do~Loopステートメント

    Do~Loopステートメントで使わな方が良いステートメントとは? Do~Loopステートメントで「古いから使わない方がよい」、と言われたことがあるのですが どれの事だか忘れてしまいました。 Sub test() セルのA1~A10に1~10を入力する i = 1 Do While i < 11 Worksheets("Sheet1").Cells(i, 1).Value = i i = i + 1 Loop End Sub これは一般的だから使ってもよいと思います。 Sub test() セルのA1~A10に1~10を入力する i = 1 Do Until i = 11 Worksheets("Sheet1").Cells(i, 1).Value = i i = i + 1 Loop End Sub これもよく見かけます。 Do While,Do Until以外にもloopステートメントってありますか? あと使わない方が良いステートメント、私の勘違いでなければ教えてください。

  • VBA Do Until Loopでエラー

    VBAは全くの素人です。 マクロの記録とInterNetでVBAコードを探し、下記のように記しました。 VBAのデバッグ&ステップインで(動作)確認するのですが、素人の悲しさか、Do Until IF の行で「コンパイル&構文エラー」に引っ掛かり先に進めません。 どの様に修正したらよいのかnetを探すのですが見つかりません。(探し方が足りない?) コードの右側に ‘‥‥やりたい事のコメントを記しています。 どの様にコードを修正したらよいのか、ご指導願えませんでしょうか?。 他の部分についてもご指導頂けると助かります。 Sub 練習1() Dim i As Integer '‥‥変数(繰り返し回数のカウント) iを宣言 i = 0 '‥‥変数iをリセット(0)にする(繰り返し回数のカウント) Range("$F$8").Select ActiveCell.FormulaR1C1 = 0 '‥‥F8をリセット(0)にする Dim waittime As Variant '‥‥待ち時間設定宣言 waittime = Now + TimeValue("0:00:10") '‥‥待ち時間10秒に設定 Do Until If Range("$G$8").Value = "Out" Then '‥‥「Goodになるまで繰り返しなさい」 Calculate ‘‥‥繰り返し計算せよ Else: Range("$G$8").Value = "Good" ‘‥‥Goodになれば繰り返し(Loop)完了 IF Range("$G$8").Value = Interior.colorIndex = 36 '‥‥$G$8が"Good"ならばセル色を36にする '尚、G8セルの計算式は=IF(AND($I$25="OK",$I$26="OK",$I$27="OK",$I$28="OK",$I$29="OK"),"Good","Out") Range("F8").Select ActiveCell.FormulaR1C1 i = i + 1 '‥‥変数iを1増やす(繰り返し回数のカウント) waittime = Now + TimeValue("0:00:10") '‥‥待ち時間10秒に設定 End If Calculate Loop '‥‥G8が”Good” になればVBA終了 Range("G8").Select End Sub

  • Do loopのマクロ

    以下のマクロの問題点を教えていただきたいのです。 A列を上から順番に調べて、値が10のときだけBに分岐して処理を行い(処理の内容は省略してあります)、またAに戻って、空白のセルが見つかったら処理をやめる、というマクロです。 ところが、これを実行すると空白のセルが見つかってもマクロが止まりません。何が問題でしょうか。 Sub A() Cells(1, 1).Select A: Do Until ActiveCell.Value = "" If ActiveCell.Value = 10 Then GoTo B End If ActiveCell.Offset(1, 0).Select Loop B: ActiveCell.Offset(1, 0).Select GoTo A End Sub

  • Excel VBA のDo Until Loopについて

    こんばんは Excel VBAの初心者です。 Do Until Loopを使って B列の値が変わるところ(下記の表だと、空白からコスモスに変わる、4行目。コスモスからチューリップに変わる6行目。チューリップから菊に変わる8行目。)に行を挿入させたいと思い、下記のマクロを組んだのですが、Do Until Loopが理解できませんでした。 どうしたら良いのか教えて頂けないでしょうか。 宜しくお願い致します。 Excelのシート B1  項目 B2  空白 B3  空白 B4  コスモス B5  コスモス B6  チューリップ B7  チューリップ B8  菊 Sub 行の挿入() Dim y As String Cells(2, 2).Select y = Cells(2, 2).Value Do Until Cells(2, 2).Value <> y ActiveCell.Offset(1).Select Selection.EntireRow.Select Selection.Insert shift:=xlDown Loop End Sub

  • loop終了後のセルの一個右から同様のloopを行う方法

    ・loop終了後のセルの一個右から同様のloopのプログラムを組むのが目的です。 ・データはA列にランダムに数字が入っているものとします。 ・条件式としては基準値より小さな数字が一個下のセルにあったら↓を表示して、さらに下に行くという風にして、基準よりも多くなったところでloopがストップする設定です。 ・困っているところをうまく表現できてないかも知れませんが、よろしくお願いします。 --------------------------- Sub 比較() Dim i As Integer Dim j As Integer Cells(1, 2).Select ActiveCell.FormulaR1C1 = "=IF(RC1>R1C1,""→"",""↓"")" i = 1 Do While Cells(i, 2).Value <> "" If Cells(i, 2).Value = "↓" Then Cells(1 + i, 2).Select ActiveCell.FormulaR1C1 = "=IF(RC1>R1C1,""→"",""↓"")" End If i = i + 1 Loop Cells(i - 1, 3).Select ActiveCell.FormulaR1C1 = "=IF(RC1>R" & i - 1 & "C1,""→"",""↓"")" j = 1 Do While Cells(i - 2 + j, 3).Value <> "" If Cells(i - 2 + j, 3).Value = "↓" Then Cells(i - 1 + j, 3).Select ActiveCell.FormulaR1C1 = "=IF(RC1>R" & i - 1 & "C1,""→"",""↓"")" End If j = j + 1 Loop End Sub

  • VBA Do~Loopについて

    VBA勉強中です。 マクロの作成は完了しているのですが、処理効率について指摘を受け、 その際に助言もいただいたのですが、自身の勉強不足、理解不足で どのように変更すれば良いのか分からず、教えていただきたいです。 Do While Ax2 <= 30 で30回繰り返すのではなく (Cells(Ax2,"B").Value <> "" ) の間繰り返すように変更したいです。 ---------------- Sub test()  Dim File1(30) As string  Dim Sheet1(30) As string  Dim Sheet2(30) As string  Dim Cnt As Integer  Ax1=1  Ax2=7  Do While Ax2 <= 30    If Cells(Ax2, "B").Value <> "" Then     File1(Ax1) = Cells(Ax2, "B").Value     Sheet1(Ax1) = Cells(Ax2, "C").Value     Sheet2(Ax1) = Cells(Ax2, "D").Value     Cnt =Ax1    End If    Ax1 = Ax1 + 1    Ax2 = Ax2 + 1  Loop End Sub ---------------- お手数ですが、よろしくお願いいたします。

  • 2重のDo~Loopは?

    Excel VBAですが、A列にデータが入っています。 A列のデータが変わるまで 処理1 を実行し、変われば 処理2 を実行する。データがなくなれば終了する方法が分りません。宜しくお願いします。 i = 2 Do Until Cells(i, 1) = "" Do Until Cells(i, 1) <> Cells(i - 1, 1) 処理1 Loop 処理2 Loop

  • VBA 九九 Do While

    VBAのDo Whileステートメントを使って九九の表をつくりたいのですが、何度やっても途中で詰まり、実行に至りません。 For NextとDo untilではできたと思うのですがDo Whileがどうしてもわからなくて… どなたか助けてください。お願いします。 Sub 九九計算_for() Dim i, j As Integer For i = 1 To 9 For j = 1 To 9 Cells(i, j).Value = i * j Next Next End Sub Sub 九九計算_do_until() j = 1 Do i = 1 Do Cells(j, i).Value = i * j i = i + 1 Loop Until i = 10 j = j + 1 Loop Until j = 10 End Sub

  • :【Excel VBA】 Do Until ~ Loop 構文で途中の空白セルを飛ばしてデータのチェックをしたい

    こんにちは。 Do Until ~ Loop 構文で 空白セルまでループして重複する値をチェックしたいと考えています。 --------------------------------------------- Sub 重複チェック() Dim 検索語 As String Dim 該当数 As Long Dim 確認 As Integer Range("A4").Activate Do Until ActiveCell.Value = "" 検索語 = ActiveCell.Value 該当数 = WorksheetFunction.CountIf(Range("A:A"), 検索語) If 該当数 >= 2 Then ActiveCell.AutoFilter Field:=1, Criteria1:=検索語 確認 = MsgBox("次を検索しますか?", vbYesNo) If 確認 = vbNo Then Exit Sub End If ActiveCell.Offset(1, 0).Activate Loop Range("A4").AutoFilter MsgBox "名前の重複チェックが終了しました。" End Sub --------------------------------------------- ただセルA列には行の途中、空白も含まれているため、 途中で止まってしまいます。 今後A列にはデータが追加されていきます。 途中の空白セルを飛ばして、 データーの最後までチェックするにはどのようにすればよいでしょうか?

  • IF・DoなどVBAについて

    部品の在庫に対する発注数を算出するプログラムを下記の条件で作成中です。 ご指導願います。 A・B・Cの3種類の機械があり、それぞれ2種類の部品を持っています。 A・B・Cの3種類の機械があり、それぞれ指定した残量になると発注数を算出する。 1.Aの限界在庫 box1:50000 box2:5000 2.Bの限界在庫 box1:40000 box2:4000 3.Cの限界在庫 box1:30000 box2:3000 4Aの発注基準値 box1:30000 box2:3000 5.Bの発注基準値 box1:20000 box2:2000 6.Cの発注基準値 box1:10000 box2:1000 7.発注基準値の切り捨て  1の単位までありますので下記の単位で切り捨てます。 box1:10の単位で切り捨て box2:10の単位で切り捨て 8.A列にA・B・Cの機械の識別IDがランダムにあります。 9.B列にbox1の在庫があります。 8.C列にbox2の在庫があります。 8.D列にbox1の在発注数を表示します。。 8.E列にbox1の在発注数を表示します。 Sub 計算1() Dim i As Integer Dim Abox1, Abox2, Bbox1, Bbox2, Cbox1, Cbox2 As Long Dim Aboxh1, Aboxh2, Bboxh1, Bboxh2, Cboxh1, Cboxh2 As Long Abox1 = 50000 'Abox1容量 Abox2 = 5000 'Abox2容量 Bbox1 = 40000 'Bbox1容量 Bbox2 = 4000 'Bbox2容量 Cbox1 = 30000 'Cbox1容量 Cbox2 = 3000 'Cbox2容量 Aboxhk1 = 30000 'Abox1発注基準値 Aboxhk2 = 2000 'Abox2発注基準値 Bboxhk1 = 20000 'Bbox1発注基準値 Bboxhk2 = 2000 'Bbox2発注基準値 cboxhk1 = 10000 'Cbox1発注基準値 cboxhk2 = 1000 'Cbox2発注基準値 Aboxhs1 = 30000 'Abox1発注数 Aboxhs2 = 2000 'Abox2発個数 Bboxhs1 = 20000 'Bbox1発個数 Bboxhs2 = 2000 'Bbox2発個数 cboxhs1 = 10000 'Cbox1発注数 cboxhs2 = 1000 'Cbox2発注数 i = 2 Aboxhs1 = Abox1 - Cells(i, 2) Aboxhs2 = Abox2 - Cells(i, 3) Bboxhs1 = Bbox1 - Cells(i, 2) Bboxhs2 = Bbox2 - Cells(i, 3) cboxhs1 = Cbox1 - Cells(i, 2) cboxhs2 = Cbox2 - Cells(i, 3) Do While Worksheets("sheet1").Cells(i, 1) = "A" If Cells(i, 2) < Aboxhk1 Or Cells(i, 3) < Aboxhk2 Then Worksheets("sheet1").Cells(i, 4) = Application.WorksheetFunction.RoundDown(Aboxhs1, -3) Worksheets("sheet1").Cells(i, 5) = Application.WorksheetFunction.RoundDown(Aboxhs2, -2) End If i = i + 1 Loop Do While Worksheets("sheet1").Cells(i, 1) = "B" If Cells(i, 2) < Bboxhk1 Or Cells(i, 3) < Bboxhk2 Then Worksheets("sheet1").Cells(i, 4) = Application.WorksheetFunction.RoundDown(Bboxhs1, -3) Worksheets("sheet1").Cells(i, 5) = Application.WorksheetFunction.RoundDown(Bboxhs2, -2) End If i = i + 1 Loop Do While Worksheets("sheet1").Cells(i, 1) = "C" If Cells(i, 2) < cboxhk1 Or Cells(i, 3) < cboxhk2 Then Worksheets("sheet1").Cells(i, 4) = Application.WorksheetFunction.RoundDown(cboxhs1, -3) Worksheets("sheet1").Cells(i, 5) = Application.WorksheetFunction.RoundDown(cboxhs2, -2) End If i = i + 1 Loop End Sub