• ベストアンサー

VBAでDateaddの日付計算で困っていることがあるので助けていただけないでしょうか。よろしくお願いします。

シート: A列には”注射”という文字を入れるようにします。 B列には1月1日から12月31日まで入っています。 C列はB列の90日後を入れるようにします。 D列はC列の3日前を入れます。・・・としたいのですがその3日の間A列に”注射”が入っていたらその日を入れずに3日前にしたいのです。 稼働日みたいな感じでしょうか・・・・ どうしたらよいでしょうか?お願いします。 例えば、B列の「1月1日」の90日後はC列「3月31日」でD列は通常「3月28日」が入っていますがB列「3月30日」の左のA列に”注射”があったらそこを無視して「3月27日」と入れたいのです。 Sub count() Dim i As Long Dim lastrow As Long lastrow = Range("B1").End(xlDown).Row For i = 1 To lastrow Cells(i, 3).Value = DateAdd("d", 90, Cells(i, 2).Value) Next For i = 1 To lastrow Cells(i, 4).Value = DateAdd("d", -3, Cells(i, 3).Value) Next End Sub 説明が下手なのでもしよかったら実際作ったものを見ていただいた方が分かるかもしれません。 http://briefcase.yahoo.co.jp/bc/robert_kubica_bmw/vwp2?.tok=bcf8oGbB4FXgt88k&.dir=/&.dnm=1count.xls&.src=bc

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

  • ベストアンサー
  • Masa2072
  • ベストアンサー率51% (94/182)
回答No.4

色々と勘違いがあるようでスイマセン。 これでどうでしょうか? Sub count()   Dim i, j   Dim BLK      With ActiveSheet     For i = 1 To .Range("B1").End(xlDown).Row       .Cells(i, "C") = .Cells(i, "B") + 90       .Cells(i, "D") = .Cells(i, "B") + 90       BLK = 0       '90日後の1日前からA列値が"注射"でない日を三つカウントするまで日付を遡る       For j = i + 89 To 1 Step -1         If .Cells(j, "A").Value <> "注射" Then           BLK = BLK + 1         End If         .Cells(i, "D") = .Cells(i, "D") - 1         If BLK = 3 Then Exit For '注射ではない日を3個カウントしたので遡る処理を中止       Next     Next   End With End Sub

komarimono
質問者

補足

ありがとうございます。私自身混乱しているので一度要件を整理しなおします。90日というのはコードで作る必要がなくなったのでとにかくC列に入っている日付から3日前倒すがA列に特定文字があれば休みとし稼動日のみ3日前倒す を考えてます 色々すみません サンプルで別のを作ってみましたがなかなか・・・・ Sub count() Dim i As Long Dim j As Long Dim lastrow As Long Dim ctr As Long lastrow = Range("D12").End(xlDown).Row ’For i = 12 To lastrow ’ Cells(i, .Value = DateAdd("d", 30, Cells(i, 4).Value) ’Next For i = 12 To lastrow j = lastrow Do While Cells(i, .Value <> Cells(j, 4).Value j = j - 1 If j = 0 Then Exit Sub Loop Do While ctr < 4 If InStr(1, Cells(j - 1, 7).Value, "病院", 1) = 0 Then ctr = ctr + 1 End If j = j - 1 Loop Cells(i, 11).Value = Sheets("Sheet1").Cells(j, 4).Value ctr = 0 Next End Sub

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

その他の回答 (3)

  • Masa2072
  • ベストアンサー率51% (94/182)
回答No.3

ANo.2です。 > もし、注射が存在すれば数に関係なく1日だけ遡るのであればEnd Ifの次行にExit Forを入れてください。 次行ではなく前行の間違いでした。

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

> ・・・としたいのですがその3日の間A列に”注射”が入っていたら ここが少しわかりにくいですね 1/1の90日後(3/31)の3日前である3/28~3/30の3日間と言うことでしょうか? 3/28横に"注射"とあれば3/27になるというのはわかるのですが、29日にも"注射"とあれば、3/26日になるのでしょうか? 仮にそのようだとして私ならマクロとしては Sub count()   Dim i, j   With ActiveSheet   For i = 1 To .Range("B1").End(xlDown).Row     .Cells(i, "C") = .Cells(i, "B") + 90 '90日後の日付を格納     .Cells(i, "D") = .Cells(i, "B") + 87 '90-3日後の日付を格納     '1日前から3日前までの間に注射があれば、その分日付を遡る     For j = 1 To 3       If .Cells(i + 90 - j, "A") = "注射" Then         .Cells(i, "D") = .Cells(i, "D") - 1       End If     Next   Next   End With End Sub もし、注射が存在すれば数に関係なく1日だけ遡るのであればEnd Ifの次行にExit Forを入れてください。 ※個人的に日数加算はDateAddよりも単純に日数を加減した方が分かりやすいのでこうしました。 またこの程度であればマクロでなくともワークシート関数のみでも可能です。 C1に =B1+90 注射の数分遡る場合 D1に =B1+87-(COUNTIF(OFFSET(A1,87,0,3,1),"注射")) 注射があれば1日だけ遡る場合 D1に =B1+87-IF(ISERROR(MATCH("注射",OFFSET(A1,87,0,3,1)),0,1) あとは下にコピー

komarimono
質問者

お礼

説明が下手ですみません その3日だけ作りたいのではないのでプログラムしているのですが基本的にA列どこにでも注射は入ります。 注射のはいったセルを抜かして3日間をカウントしたいといった感じです。稼働日計算のようなものだとは思いますが・・・ ですので例えばB92に4月1日があったときC92は6月30日でD92は6月27日が入ってますが該当日付のA列に注射が入っていればその日を飛ばして3日前を計算したいので6月26日、もし注射という文字列が連続で入っていればそれだけさかのぼっていきます

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

If Cells(i, 1) = "注射" Then Cells(i, 4).Value = DateAdd("d", -4, Cells(i, 3).Value) Else Cells(i, 4).Value = DateAdd("d", -3, Cells(i, 3).Value) End If ではダメでしょうか。

komarimono
質問者

補足

説明が下手ですみません その3日だけ作りたいのではないのでプログラムしているのですが基本的にA列どこにでも注射は入ります。 注射のはいったセルを抜かして3日間をカウントしたいといった感じです。稼働日計算のようなものだとは思いますが・・・ ですので例えばB92に4月1日があったときC92は6月30日でD92は6月27日が入ってますが該当日付のA列に注射が入っていればその日を飛ばして3日前を計算したいので6月26日、もし注射という文字列が連続で入っていればそれだけさかのぼっていきます

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

関連するQ&A

  • Excel VBAで文字列の部分一致の文字列を表示

    以前、こちらで頭5文字までの一致で文字列を表示するVBAを教えて頂きました。今回はFINDなどの部分一致での文字列を表示することをしたいのですが、ご教示いただけますと幸いです。 下記はSheet1のA3に文字を5文字以内いれるとSheet2のC列からピックアップしてSheet1のA列に文字列を表示する及びSheet2のB列のデータをSheet1のC列に表示させるVBAです。 Sub Test2() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim SData As String, i As Long, VRet As Variant Dim c As Range, LastRow As Long Set Ws1 = Sheets("Sheet1") Set Ws2 = Sheets("Sheet2") SData = CStr(Ws1.Range("A3").Value) If SData = "" Then Exit Sub i = 5 LastRow = Ws1.Cells(Rows.Count, "A").End(xlUp).Row If LastRow < i Then LastRow = i End If Ws1.Range(Ws1.Cells(i, "A"), Ws1.Cells(LastRow, "C")).ClearContents With Ws2 For Each c In .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp)) VRet = InStr(1, CStr(c.Value), SData, vbTextCompare) If VRet = 1 And Len(c.Value) >= 10 Then Ws1.Cells(i, "A").Resize(1, 2).Value = c.Resize(1, 2).Value 'とりあえずSheet2のB列のデータ(C列のデータに同期したデータ)をSheet1のC列に Ws1.Cells(i, "C").Value = .Cells(c.Row, "B").Value i = i + 1 End If Next End With End Sub 宜しくお願い致します。

  • VBAデータ元から新規ブックに出力

    現在のブック内に出力されるとメモリの都合上時間がかかりすぎますそこで新規ブック1個に出力する構文を教えていただきたいのですが、宜しくお願いします。 Sub 1111() Dim c As Range Dim i As Integer, LastRow As Long Dim NewSheetName As String, MatchFlag As Boolean Application.ScreenUpdating = False NewSheetName = "" With Sheets("データ元") For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp)) MatchFlag = False If NewSheetName <> Year(c.Value2) & "年" & Month(c.Value2) & "月" Then NewSheetName = Year(c.Value2) & "年" & Month(c.Value2) & "月" For i = 1 To Worksheets.Count If Sheets(i).Name = NewSheetName Then Sheets(i).Cells.ClearContents MatchFlag = True Exit For End If Next i If MatchFlag = False Then Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = NewSheetName End If End If LastRow = Sheets(NewSheetName).Cells(Rows.Count, "A").End(xlUp).Row Sheets(NewSheetName).Cells(LastRow + 1, "A").Resize(1, 6).Value = .Cells(c.Row, "A").Resize(1, 6).Value Sheets(NewSheetName).Columns("A:F").EntireColumn.AutoFit '↑A列からF列まで自動幅調整してます Next .Activate End With Application.ScreenUpdating = True MsgBox "終了しました", vbInformation End Sub

  • 【VBA】土日をスキップして日付計算

    今A列に土日を除いた日付があり、マクロを実行すると、日付が一日加算される下記のようなVBAを書いてます。 Sub DateCulc() i = 3 Do dodate = (DateAdd("d", 1, Cells(i, 1))) Cells(i, 1) = dodate i = i + 1 Loop While Cells(i, 1).Value <> "" End Sub 一日加算した場合、土日をスキップ、つまり金曜の日付は月曜になるようにしたいのですが、思いつきません。WeekDayを使うのだと思うのですが。 ご教授頂けますか。宜しくお願いします。

  • それぞれテキストファイに区切って出力

    添付画像のような構成で  C列数値(D列の文字数の総計)を上から順番に合計して300を超えるとB列にその合計を書き出すようにしました。  (コード SumIfOver300) わかりやすいようにA列にそれぞれを塗分けしています。 1) 現在は、手動ですがこれをVBAで自動で処理したい。 (添付図は、3色ですが境目が解ればいいので2色でもOKです。) 2) 塗分け後に塗分けされたD列の部分を一つのテキスト群としてそれぞれ別ファイル(テキストファイル)に区切って出力したい。 添付図で言うといかのように出力  D2:D7  001_text.txt D8:D12 002_text.txt D13:D15 003_text.txt Sub SumIfOver300() Dim lastRow As Long Dim sum As Long Dim i As Long lastRow = Cells(Rows.Count, "C").End(xlUp).Row sum = 0 For i = 1 To lastRow sum = sum + Cells(i, "C").Value If sum > 300 Then Cells(i, "B").Value = sum sum = 0 End If Next i End Sub

  • VBA 請求データ一覧からの複数の処理

    先週 kkkkkmさんに質問をさせて頂きまして、 いろいろご指導を頂いたものです。 続編の様な形になってしまいますが、 抽出するデータの環境設定を変更致しました。 ご質問させて頂く内容は前回とほとんど変更がないのですが、 あらためて下記に記載させて頂きます。 <Worksheet1のデータ> J列~AM列までが課税金額 「J,K,L」「M,N,O」・・・「AK,AL,AM」と3列1組(コード・費目・金額) 1組の行もあれば、複数組の行もあり。 AN列~BB列までが非課税金額 課税金額と同じく3列1組 1組の行もあれば、複数組の行もあり。 「BC」=消費税、「BD」=合計金額 ※AN列の前に不規則な空白セルあり   BC列の前に不規則な空白セルあり 文章で上手く説明出来ているか自信がありませんので、 エクスポートした元データ Worksheet1と、 vbaを用いて作成した Worksheet3 をご参考に添付致します。 Worksheet1の2行目がWorksheet3の2行目に対応しています。 3行目、4行目も同様です。 不規則な空白が原因でしょうか・・・。 M列、O列は問題ないのですが、 金額が合わなかったり、N列に金額を引いてこないのです。 実行しているコードは下記になります。 Dim i As Long, j As Long, k As Long Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet Dim mTotal(4) As Long Dim LastRow As Long Dim List(4) As Variant Set Ws1 = Sheets("Sheet1") Set Ws2 = Sheets("Sheet2") Set Ws3 = Sheets("請求書ひな形") List(1) = Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp)).Value List(2) = Ws2.Range(Ws2.Cells(1, "B"), Ws2.Cells(Rows.Count, "B").End(xlUp)).Value List(3) = Ws2.Range(Ws2.Cells(1, "C"), Ws2.Cells(Rows.Count, "C").End(xlUp)).Value List(4) = Ws2.Range(Ws2.Cells(1, "D"), Ws2.Cells(Rows.Count, "D").End(xlUp)).Value LastRow = UBound(List(1)) For i = 2 To 4 If LastRow < UBound(List(i)) Then LastRow = UBound(List(i)) End If Next For i = 2 To Ws1.Cells(Rows.Count, "J").End(xlUp).Row mTotal(1) = 0 mTotal(2) = 0 mTotal(3) = 0 mTotal(4) = 0 For j = Columns("J").Column To Columns("BB").Column Step 3 For k = 2 To LastRow If UBound(List(1)) >= k Then If Ws1.Cells(i, j).Value = List(1)(k, 1) Then mTotal(1) = mTotal(1) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(2)) >= k Then If Ws1.Cells(i, j).Value = List(2)(k, 1) Then mTotal(2) = mTotal(2) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(3)) >= k Then If Ws1.Cells(i, j).Value = List(3)(k, 1) Then mTotal(3) = mTotal(3) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(4)) >= k Then If Ws1.Cells(i, j).Value = List(4)(k, 1) Then mTotal(4) = mTotal(4) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If Next Next Ws3.Cells(i, "J").Value = mTotal(1) Ws3.Cells(i, "K").Value = mTotal(2) Ws3.Cells(i, "L").Value = mTotal(3) Ws3.Cells(i, "N").Value = mTotal(4) Ws3.Cells(i, "M").Value = Ws1.Cells(i, "BC").Value Ws3.Cells(i, "O").Value = Ws1.Cells(i, "BD").Value Next Set Ws1 = Nothing Set Ws2 = Nothing Set Ws3 = Nothing End Sub 本当に何度も申し訳ございません。 お時間がある時に見て頂けると有り難いです。 どうぞ宜しくお願い致します。

  • VBA転記について教えて下さい

    200件位のデータがあるとします。顧客情報AB・商品C~AY 氏名 性  青森りんご 長野りんご みかん バナナ 送料 AA  男   1             2      100 BB  女          1            100 CC  男                   3     0 このデータを別シートAにはりんごと送料 別シートBにはそれ以外のデータに分けたいのです。 シートA 氏名 性  青森りんご 長野りんご  送料 AA  男   1           100 BB  女        1    100 CC  男 シートB 氏名 性  みかん バナナ AA  男    2 BB  女 CC  男       3 こんな感じです。 色々参考にして作成しましたがうまくいきませんでしたので 教えて欲しいです。 よろしくお願いします。 エクセルは2002です。 1、項目名の転記でデータは200位ですが変動があるので最終行で作成したら うまくいきませんでした。 2、データ域の転記が動きません。 Sub サンプル() Dim i As Long Dim lastRow As Long Dim lastcolumns As Long Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet Dim myColumns As Long Dim myKey As String Set S1 = Worksheets("データ") Set S2 = Worksheets("りんご") Set S3 = Worksheets("その他") ' Sheet1の最終行を取得 lastRow = S1.Range("A" & Rows.Count).End(xlUp).Row ' Sheet1の最終列を取得 lastcolumns = S1.Cells(1, Columns.Count).End(xlToLeft).Column ' 項目名の転記 S2.Range("A1:B200").Value = _ S1.Range("A1:B200").Value S3.Range("A1:B200").Value = _ S1.Range("A1:B200").Value 'データ域の転記 For i = 2 To lastcolumns myKey = S1.Cells(1 & i).Value If myKey <> "" Then myColumns = Worksheets(myKey).Cells(1, Columns.Count).End(xlUp).Columns + 1 S1.Range(S1.Cells(1, i), S1.Cells(lastRow, i)).Copy _ Worksheets(myKey).Range(Cells(1, myColumns), Cells(lastRow, myColumns)) End If Next i End Sub

  • エクセルのフォームのVBAについて

    VBAがまったくわからないのに参考書を見て高度な事に挑戦しています フォームは作れてフォームをクリックやら入力やらして作ったOKボタンを押すと シート2のA1B1C1‥の列に入力文字だけが羅列されます。 しかし次にやろうとするとA2B2C2‥と下に行かず又A1B1C1‥の列の文字が変更になり続きません。何がいけないのでしょうか? Sub 入力() Dim LastRow As Long With Worksheets("sheet2") LastRow = Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row .Range("A" & LastRow).Value = Worksheets("sheet1").Range("A5").Value .Range("B" & LastRow).Value = Worksheets("sheet1").Range("A7").Value .Range("C" & LastRow).Value = Worksheets("sheet1").Range("A8").Value .Range("D" & LastRow).Value = Worksheets("sheet1").Range("A10").Value End With End Sub と参考書とおりいれたのですが‥。教えて下さい。

  • エクセルVBA

    エクセル2003です 勉強中です 教えてください Sheet1     A      B      C       D      1   日付    種類    数量1    数量2  2   2月3日    C      300        10   3   2月4日     B      200       5 4   2月5日     A     100       20 5   2月3日     A     100       10 6   2月4日     B     200       5 7   2月5日     C     300       20 8   2月3日      A      300       20 9   2月4日     C      200        5 10  2月5日     B     100       10 Sheet1     F      G      H       I      1   日付    種類    数量1    数量2  2   2月3日    A      400          3   2月3日     C      300       4   2月4日     B     600       5   2月5日     A     100       6   2月5日     C     400       7 したい事 *A列~D列のデータをF列からI列へ複数条件の集計をしたいのですが *A列~D列の数値が変動すると勝手に自動で集計をして欲しい(シートがアクティブでなくても) *下記コードでC列までの集計ができますがD列の集計がわかりません  (増やそうとすると頭の中がぐちゃぐちゃになって・・・) *前回の集計が残ってしまう Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myDic As Object, myKey, myItem Dim myVal, myVal2, myVal3 Dim i As Long Range("F2", Range("I" & Rows.Count).End(xlUp)).ClearContents Range("F1:I1").Value = Range("A1:D1").Value Set myDic = CreateObject("Scripting.Dictionary") ' データを配列に格納 myVal = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value ' myDicへデータを格納 For i = 1 To UBound(myVal, 1) myVal2 = myVal(i, 1) & "_" & myVal(i, 2) If Not myVal2 = "_" Then If Not myDic.exists(myVal2) Then myDic.Add myVal2, myVal(i, 3) Else myDic(myVal2) = myDic(myVal2) + myVal(i, 3) End If End If Next 'Key,Itemの書き出し myKey = myDic.keys myItem = myDic.items For i = 0 To UBound(myKey) myVal3 = Split(myKey(i), "_") Cells(i + 2, 6).Value = myVal3(0) Cells(i + 2, 7).Value = myVal3(1) Cells(i + 2, 8).Value = myItem(i) Next Set myDic = Nothing '並べ替え Range("F2", Range("H" & Rows.Count).End(xlUp)).Sort _ Key1:=Range("F2"), Order1:=xlAscending, _ Key2:=Range("G2"), Order2:=xlAscending, _ Header:=xlGuess End Sub 頭のなかがこんがらがってしまいます お願いです 出来れば説明付きで教えていただけませんか よろしくお願いします

  • 【Excel VBA】日付の代入

    現在以下の操作を行いたく、コードを作成しています。 ・20~23行で各最大値を抽出し、C列に代入する ・最大値に紐づく日付をD列に代入する ・D列の日付が入ったセルを改行し、 2行目に"(曜日)"を入力する <現在のExcelデータ詳細> A20:"処理1" A21:"処理2" A22:"処理3" A23:"処理4" B19~AF19:日付 B20~AF23:任意の数字 C31:処理1の最大値 C33:処理2の最大値 C35:処理3の最大値 C37:処理4の最大値 D31、D33、D35、D37:日付 L(曜日)を入力予定 最大値に紐づく日付をD列に代入するところで 躓いています。 ご教示いただけないでしょうか。 現在のコードは下記の通りです。 Sub 最大値の取得() Dim max As Long Dim row As Integer Dim column As Integer For row = 20 To 23 max = 0 For column = 2 To 32 If Cells(row, column).Value > max Then max = Cells(row, column).Value End If Next Cells((row - 20) * 2 + 31, 3).Value = max For i = 4 To 1 Step -4 '編集中 Cells((row - 20) * 2 + 31, 4).Value = Cells(row - i, column - 1) '編集中 Next End Sub

  • エクセルVBAで別のファイルの値を代入する記述

    いつもお世話になってます。 エクセル2002で、2つのファイルを使ってVBAを組みたいと考えています。 下記のコードを『ファイルB』に記述しています。 A列のデータを、B列の回数分、C列に表示させています。 このC列に表示させている部分を『ファイルA』に直接書き出すには、 どのような記述が必要なのでしょうか? 単純に『ファイルB』のC列を、『ファイルA』に、コピー&ペーストする方法もあるかと思うのですが、 せっかくなので複数ファイルを対象に処理する記述にチャレンジしています。 が、なかなか思うような結果が得られません。 アドバイスをお願いいたします。 ---------------------- Sub tes1() Dim i As Integer Dim k As Integer Dim x As Integer Dim y As Integer With ActiveSheet.UsedRange lastrow = .Cells(.Count).Row End With x = 2 For i = 2 To lastrow k = Cells(i, 2) For k = 1 To k Cells(x, 3) = Cells(i, 1) x = x + 1 Next k Next i End Sub