Do untilで判定されない

このQ&Aのポイント
  • office2010
  • WORKシートのI4802セルに2019/08/28という日付データが登録されています。J2セルに2019/1/1の日付を設定し、その右セルに+1日ずつ設定するマクロ(カレンダ日付イメージ)で、上記WORKシートのI4802セルまでの日付を設定したい。
  • 上記のマクロを実行すると、ずっと計算して、2063/10/30までいって実行時エラーで停止します。なぜ2019/08/28で終了しないのか、原因が分かりません。修正方法も教えて頂きたいです。
回答を見る
  • ベストアンサー

Do untilで判定されない

office2010 WORKシートのI4802セルに2019/08/28という日付データが登録されています J2セルに2019/1/1の日付を設定し、その右セルに+1日ずつ設定するマクロ(カレンダ日付イメージ)で、上記WORKシートのI4802セルまでの日付を設定したい。 下記がそのマクロ Sub test() Rows("1:2").Select Selection.ClearContents Range("J2") = "2019/1/1" Dim i As Long Dim day As String day = Worksheets("WORK").Range("I4802").Value i = 11 Do Until Worksheets("Sheet2").Cells(2, i + 1) = day Worksheets("Sheet2").Cells(2, i) = Worksheets("Sheet2").Cells(2, i - 1) + 1 i = i + 1 Loop End Sub 上記を実行すると、ずっと計算して、2063/10/30までいって実行時エラーで停止します。 2019/08/28で終了しないのは何故でしょう? 日付判定になってると思うのですが、原因分からず。 また、その修正方法も教えて頂きたく

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

  • ベストアンサー
  • mt2015
  • ベストアンサー率49% (258/524)
回答No.1

単純なミスです 誤:Do Until Worksheets("Sheet2").Cells(2, i + 1) = day 正:Do Until Worksheets("Sheet2").Cells(2, i - 1) = day +1にしているせいで空のセル=0と変数dayを比較しています。

3620313
質問者

お礼

回答ありがとうございます。なるほど助かりました。

その他の回答 (2)

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

すでに原因はご指摘がある。それで済なんだが。 ーー この程度のことなら、すぐ質問するのでなく、色々変数を確認して、やってみれば、原因の箇所わかることでは。 繰り返しが、すっぽ抜けるなら、ストパーの値がおかしいだけだろう。 普通は、繰り返しの終値が、注目点かな。日付の場合は、日付シリアル値という 整数(1900年来の順序数。エクセル特有の考え方)だから、文字列になっていないかなど注意するとか、関数で日付シリアル値に確実には変換して、Msgboxでも出して確認しておくとか。 Sub test() Rows("1:2").Select Selection.ClearContents Cells(2, 10) = "2019/1/1" Dim i As Long Dim day As String Days = DateValue("2019/08/28")  'DoUntiliで、式でなく、変数に一旦持たせたもので判別するのもおすすめ i = 11 '--- Do Until Worksheets("Sheet2").Cells(2, i - 1) > Days ’--前回の繰り返しで、次のために1を足しているから、直前はi-1で見る Worksheets("Sheet2").Cells(2, i) = Worksheets("Sheet2").Cells(2, i - 1) + 1 Columns(i).AutoFit i = i + 1 Loop '--- End Sub

3620313
質問者

お礼

回答ありがとうございます。そう、式の結果をdebug.printで見られなかったのです。変数に一旦持たせたもので判別、これでやろうと思います。

  • watabe007
  • ベストアンサー率62% (476/760)
回答No.2

参考に Sub test()   Dim i As Long   Dim day As Date   i = 10   day = Worksheets("WORK").Range("I4802").Value   With Worksheets("Sheet2")     .Rows("1:2").ClearContents     .Range("J2").Value = "2019/1/1"     Do Until .Cells(2, i).Value = day       i = i + 1       .Cells(2, i) = .Cells(2, i - 1) + 1     Loop   End With End Sub

3620313
質問者

お礼

回答ありがとうございます。すっきりしたマクロで分かりやすいです。

関連するQ&A

  • ExcelのVBAの配列に関する質問です。

    ExcelのVBAの配列に関する質問です。 sheet1のデータをsheet2に表示するVBAを作成しています。。 sheet1のデータは7行目からスタートし、sheet2のデータは26行目からスタートしています。。 sheet1とsheet2の列は同じ並びではないため、それぞれのシートの列番号をCellsを用いて指定しています。 Sub test1() Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 Worksheets("sheet2").Cells(j, 1) = Worksheets("sheet1").Cells(i, 2) Worksheets("sheet2").Cells(j, 8) = Worksheets("sheet1").Cells(i, 28) Worksheets("sheet2").Cells(j, 9) = Worksheets("sheet1").Cells(i, 31) Worksheets("sheet2").Cells(j, 10) = Worksheets("sheet1").Cells(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub 上記のtest1は正常に動くのですが、データ量が多いため、処理に時間がかかってしまいます。 高速化できないかと、以下のように変更しました。 Sub test2() Dim dataRange1 As Variant Dim dataRange2 As Variant dataRange1 = Worksheets("sheet1").Range("A1:GI10006") dataRange2 = Worksheets("sheet2").Range("A1:DZ10018") Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 dataRange2(j, 1) = dataRange1(i, 2) dataRange2(j, 8) = dataRange1(i, 28) dataRange2(j, 9) = dataRange1(i, 31) dataRange2(j, 10) = dataRange1(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub test2は、エラーメッセージ等は表示されませんが、sheet2にデータが表示されません。 ちなみに、以下のようにsheet1のみ配列化した場合は、正常に表示されました。 Worksheets("sheet2").Cells(j, 1) = dataRange1(i, 2) Worksheets("sheet2").Cells(j, 8) = dataRange1(i, 28) Worksheets("sheet2").Cells(j, 9) = dataRange1(i, 31) Worksheets("sheet2").Cells(j, 10) = dataRange1(i, 32) test2は、どこが間違っているのでしょうか? ご教示ください。 よろしくお願いいたします。

  • VBAでコピー&ペーストをループ化する方法

    お忙しいところ申し訳ありません、ご教授の程お願い致します。 ワークシート(1)とワークシート(2)の間で特定のセル列をコピー&ペーストしたくそれを列のデータが無くなるまで(空白まで)処理したいのですが、 単一セルの処理は Worksheets("ワークシート(1)").Range("BJ2") = Worksheets("ワークシート(2)").Range("E2") で値の貼り付けが実行され成功したのですがそれをループ化したい構文に当てはめると空白まで自動的に処理してくれるような動作をしません。 検索してしらべてみたのですが、 Sub test() Dim i As Integer i = 1 Do Until cells(i, 2) = "" cells(i, 2) = Worksheets("ワークシート(1)").cells(2, 62) = Worksheets("ワークシート(2)").cells(2, 5).End(xlDown) i = i + 1 Loop End Sub で、試してみましたが動作しなかったです。 お忙しいところ申し訳ありませんが、宜しく御願い申し上げます。

  • 判定してセルを塗りつぶすマクロについて

    判定してセルを塗りつぶすマクロについて教えて下さい。 現在下記のようなマクロがあります。 Sub オニオン判定() Dim i As Integer, j As Integer, r As Integer Dim k As Double Range(Cells(17, 9), Cells(26, 14)).Interior.ColorIndex = 0 Range(Cells(30, 9), Cells(39, 14)).Interior.ColorIndex = 0 k = Cells(5, 2) 'B5セルの値 For j = 9 To 14 For i = 17 To 26 For r = 30 To 39 If Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then Cells(r, j).Interior.Color = vbYellow Cells(i, j).Interior.Color = vbYellow End If Next  Next   Next End Sub 対象のIf Abs(Cells(i, j).Value - Cells(r, j).Value) <= 0.05 Then で、それぞれ見比べて、0.05以上のずれがあるとセルが塗りつぶされないというマクロなのですが これを、If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenという条件も追加して その時はセルを青に塗りつぶし、逆に0.05以上のずれがあるセルは赤に塗りつぶす。 みたいなマクロを書きたいです。 If Abs(Cells(i, j).Value - Cells(r, j).Value) = 0 Thenは一度追加してみましたが 上手く機能しませんでした。 やりたい事 ・数値が動いているけど、0.05以内の時は黄色 ・数値変動が0の場合は青 ・数値変動が0.05以上の場合は赤 です。 宜しくお願いします。

  • マクロ初心者(;◔ิд◔ิ)オーバーフロー!!

    異なるシートで一致するデータがあった場合、 そのセルを選択して値貼り付けするというマクロを作りました。 作ったとはいえ、 教えてもらったマクロを試行錯誤して使えるようにアレンジしただけなので、 なにがなんだかよくわかっていません。 下記の記述でマクロを使用していましたが、 突然エラーになって使用できなくなりました。。。。 中身を見ると If Worksheets("master sheet").Cells(i, "BL").Value = Worksheets("請求書フォーム").Range("J1").Value Then この部分が黄色に塗りつぶされてるのですが、 どこをどう直したらいいのか全くわかりません。 ちなみに、ほかのファイルでも同じようなマクロを使用していますが、 そちらは問題なく使用できています。 なんとか教えていただけないでしょうか。 よろしくお願いします!!!! Sub こぴぺ() ' ' こぴぺ Macro Dim sheet1 As Worksheet Set sheet1 = Worksheets("請求書フォーム") sheet1.Activate Dim target As Range Dim i As Long Worksheets("請求書フォーム").Range("J1").Select For i = 1 To Worksheets("master sheet").Range("BL65536").End(xlUp).Row If Worksheets("master sheet").Cells(i, "BL").Value = Worksheets("請求書フォーム").Range("J1").Value Then If target Is Nothing Then Set target = Worksheets("master sheet").Range("BL" & i) Else Set target = Union(target, Worksheets("master sheet").Range("BL" & i)) End If End If Next i Set sheet1 = Worksheets("master sheet") sheet1.Activate If Not target Is Nothing Then target.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False End Sub

  • Excellマクロ Cellsの範囲選択について

    エクセル2003についてお尋ねします。 A1には行番号にあたる変数が表示されるようになっています。 その変数によって選択するセルの範囲が変わるようにすることが目的でした。 「A1の行番号の5~10列目を選択する」というマクロを 下記のような記述を行いましたが、※のところでエラーが出てしまい、問題がわからずにおります。 お手数ですが解決策をご教授ください。 Sub マクロ1() Dim j As Integer j = Range("A1") Worksheets("Sheet1").Activate Range(Cells(j, 5), Cells(j, 10)).Select ←※ End Sub よろしくお願いいたします。

  • Excelのマクロについての質問です。マクロに関しては初心者です。

    Excelのマクロについての質問です。マクロに関しては初心者です。 温度を計測する実験をしています。sheet1に計測している数値が更新されていってどんどん書き込まれている状況です。 Dim fStop As Boolean 'グローバル変数を宣言 Private Sub Command1_Click() ' ' Macro1 Macro ' ' Dim iRows As Integer Dim sRows As String Dim i As Integer Dim tm As Single fStop = Fal For i = 1 To 500 Cells(1, 1) = i tm = Timer() + 5 Do DoEvents Loop While Timer() < tm ' 最終行の調査: iRows = Worksheets("Sheet1").UsedRange.Rows.Count ' 最終行をシート3にコピー Worksheets("Sheet1").Rows(iRows).Copy Destination:=Worksheets("Sheet4").Range("1:1") ' CH1 の最新データをシート3にコピー Worksheets("Sheet3").Range("B9").Value = Worksheets("Sheet1").Cells(iRows, 3).Value ' CH2 の最新データをシート3にコピー Worksheets("Sheet3").Range("C9").Value = Worksheets("Sheet1").Cells(iRows, 4).Value ' CH3 の最新データをシート3にコピー Worksheets("Sheet3").Range("D9").Value = Worksheets("Sheet1").Cells(iRows, 5).Value Next i End Sub Private Sub Command2_Click() fStop = True End Sub 上記のプログラムを作り、sheet1に書き込まれていってる数値の一番新しい数値のみをsheet3の特定のセルの場所に更新されていくように作りました。(コマンドボタン1で計測を開始、コマンドボタン2で計測終了) しかし計測する場所が増えるにつれて下記の部分のプログラムを増やさなければいけません。このプログラムを一まとめにして、指定されたsheet3のセルに書きこまれるようにしたいのですが、どのようなプログラムを加えればいいのでしょうか?Excelのバージョンは2003です。 ' CH1 の最新データをシート3にコピー Worksheets("Sheet3").Range("B9").Value = Worksheets("Sheet1").Cells(iRows, 3).Value ' CH2 の最新データをシート3にコピー Worksheets("Sheet3").Range("C9").Value = Worksheets("Sheet1").Cells(iRows, 4).Value ' CH3 の最新データをシート3にコピー Worksheets("Sheet3").Range("D9").Value = Worksheets("Sheet1").Cells(iRows, 5).Value

  • 同じセル位置にシートの連番をつけたい

    Excel2007でマクロ作成の初心者です。 すべてのシートのR15セルに、シートの順番どおり 1から連番で番号をつけたいです。 途中でシートを削除したときも、即座に新しい連番が表示されるようにしたいです。 どうつくったらいいか、皆目わかりません。よろしくお願いします。 Sub test() Dim i As Integer For i = 1 To (Worksheets.Count - 3) Cells(18, 15) = Worksheets(i) Range("R15").Formula = "="1"" Next i End Sub

  • コピペマクロを高速化したい(Excel)

    見よう見まねで以下のようなコードを書いてみたのですが、 これだと表示にやや時間がかかるので改善したいです。 ------ Sub コピペ() Dim i As Long i = Range("A1") Range("C12").Value = Worksheets("sheet2").Cells(i, 2).Value Range("D12").Value = Worksheets("sheet2").Cells(i, 3).Value Range("E12").Value = Worksheets("sheet2").Cells(i, 4).Value Range("F12").Value = Worksheets("sheet2").Cells(i, 5).Value Range("G12").Value = Worksheets("sheet2").Cells(i, 7).Value ------ こんな感じでコピペしたい値があと15個くらいあります。 コピー元とコピー先のセル配置には法則性があまりありません。 よろしくお願いします。

  • 行ごとに判定するマクロについて教えて下さい

    行ごとに判定するマクロについて教えて下さい。 下記のようなマクロで、添付ファイルのように、行ごとで E列からN列で違った数値がないか、入力されていないセルがないかを調べ 4つすべてのセルが同じ数値でない場合は塗りつぶしはされず O列にOKを表示しないようなマクロを組みたいのですが 現在のマクロだと、行ごとではなく、E3~N102セルまでの中で 同じ数値がないかを判断してしまっているため K11セルやK15セルのように数値が入力されていないにも関わらずO列の部分にOKが出てしまいます。 他の行に同じ数値が入っているのは関係なしにして 11行目なら11行目だけで 15行目なら15行目だけで、というように行ごに判定していくには どのようにすればいいでしょうか? Sub 判定マクロ回転() Dim i As Integer, j As Integer Range(Cells(3, 15), Cells(102, 15)).ClearContents For i = 3 To 102 For j = 5 To 14 Cells(i, j).Interior.ColorIndex = 0 If WorksheetFunction.CountIf(Range("E3:N102"), Cells(i, j)) > 3 Then If Cells(i, j).Row Mod 2 = 1 Then Cells(i, j).Interior.ColorIndex = 6 Cells(i, 15) = "OK" Else If Cells(i, j).Row Mod 2 = 0 Then Cells(i, j).Interior.ColorIndex = 40 Cells(i, 15) = "OK" End If End If End If Next j Next i If WorksheetFunction.CountIf(Range("O3:O102"), "OK") > 99 Then MsgBox "データチェックOK(^O^)b" End If End Sub

  • ExcelVBAテキストでの疑問

    Option Explicit Sub 請求書作成(Kokyaku As String) '引数「Kokyaku」は請求書を作成する顧客名 ここだけなぜ「請求書作成」、引数を宣言するのかが不明です。    Dim i As Integer '「販売」ワークシートの表の処理用カウンタ変数 Dim Cnt As Integer '請求書のワークシートの表の処理用変数 Cnt = 12 '請求書のワークシートの表の先頭行(12行目)の値に初期化 'ワークシート「請求書雛形」を末尾にコピー Worksheets("請求書雛形").Copy After:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).Name = Kokyaku 'ワークシート名を設定 Worksheets(Kokyaku).Range("A6").Value = Kokyaku '請求書の宛先を設定 Worksheets(Kokyaku).Range("E2").Value = Date '請求書の発行日を設定 '指定した顧客の販売データを請求書へコピー For i = 4 To 32 If Worksheets("販売").Cells(i, 2).Value = Kokyaku Then Worksheets(Kokyaku).Cells(Cnt, 1).Value = Worksheets("販売").Cells(i, 1).Value '日付 Worksheets(Kokyaku).Cells(Cnt, 2).Value = Worksheets("販売").Cells(i, 3).Value '商品 Worksheets(Kokyaku).Cells(Cnt, 3).Value = Worksheets("販売").Cells(i, 4).Value '単価 Worksheets(Kokyaku).Cells(Cnt, 4).Value = Worksheets("販売").Cells(i, 5).Value '数量 Worksheets(Kokyaku).Cells(Cnt, 5).Value = Worksheets("販売").Cells(i, 6).Value '金額 Cnt = Cnt + 1 '請求書のワークシートの表のコピー先の行を1つ進める End If Next i End Sub Sub フォーム用意() myForm.Show End Sub

専門家に質問してみよう