[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロで日付の足りない行を補填したい』（さくら）
初めまして。
リストの日付が飛んでいる箇所に行を挿入したいのですが、うまくいきません。
ご教授頂ければ幸いです。
2つのリストがあります。日付シートと日付２シート
＜日付シート＞
日付 記号 2022年3月20日 A 2022年3月20日 B 2022年3月22日 A 2022年3月22日 B 2022年3月25日 A 2022年3月25日 B 2022年3月25日 A
＜日付2シート＞
日付 記号 2022年3月17日 A 2022年3月18日 A 2022年3月18日 A
日付シートのA2セルから日付が並んでいますが、3月21日、3月23日、3月24日が抜けています。
そこを行を挿入して補填する所までは出来たのですが、
息詰まっているのは、下記2点です。
1. 日付2シートの一番最後の日付（3月18日）と日付シートの先頭の日付（3月20日）を比べて日付が飛んでいたら、そこも日付シートの先頭に行を挿入したい（3月19日を挿入したい）
2. 日付シートの最後は3月25日で終わっていますが、そこを前日までの日付が抜けていたら更に行を追加したい。例：本日は3月27日なので、前日の3月26日まで日付を追加したい。
＜Outputはこうしたい↓↓＞
日付 記号 2022年3月19日 2022年3月20日 A 2022年3月20日 B 2022年3月21日 2022年3月22日 A 2022年3月22日 B 2022年3月23日 2022年3月24日 2022年3月25日 A 2022年3月25日 B 2022年3月25日 A 2022年3月26日
＜考えたコード：抜けているコードを補填する部分のみ＞
Sub 挿入()
Range("A2").Activate
Do While IsEmpty(ActiveCell.Value) = False
ActiveCell.Offset(1, 0).Select If ActiveCell.Offset(-1, 0) > ActiveCell Then Exit Sub If ActiveCell.Offset(-1, 0) + 1 < ActiveCell Then
ActiveCell.EntireRow.Insert
ActiveCell = ActiveCell.Offset(-1, 0) + 1
End If
Loop
End Sub
例えば、1の問題は、日付2シートの一番最終行の値をまず日付シートの2行目に挿入して、その状態で上記コードを走らせ、その後2行目を削除する？？
等考えましたが、何かうまい方法が見つかりません。
また、2の問題は、上記コードとは切り離して考える必要がありますでしょうか。=TODAY()-1関数を使用するとか？？
宜しくお願いいたします。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
下記のコードを考えてみましたが、
For 日付 = Start To Last部分で型が違いますのエラーとなります。
他にもおかしな所が沢山あるかと思いますが、型が違いますと始めに出て止まってしまい他の検証が出来ていません…(*_*;
日付をループで、かつ、iもループで見ていくだけではダメな気がしています。
Countif等を加えて、一度もその日付が登場していなければ…みたいな工程をいれないとダメでしょうか。。
また、年月等も DateSerial(Year,Month,Day)等で拾わないと、日付のループで1日ずつ増えていかないでしょうか。。
勉強不足で質問がまとまっておらず、すみません。。
Sub 挿入2()
Dim Start As String Dim Last As String Dim i As Long, 日付 As String Dim LastRow As Long
Start = Sheets("日付2").Cells(Rows.Count, 1).End(xlUp).Value + 1
Last = "=TODAY()-1"
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For 日付 = Start To Last
With Sheets("日付")
If Cells(i, 1).Value <> 日付 Then
LastRow = Sheets("日付").Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(LastRow, 1) = 日付
End If
End With
Next 日付
Next i
End Sub
（さくら） 2022/03/27(日) 17:09
参考に
Sub Test()
Dim sDay As Date, eDay As Date, d As Date
Dim myR As Variant
sDay = DateAdd("d", 1, Worksheets("日付2").Cells(Rows.Count, "A").End(xlUp).Value)
eDay = DateAdd("d", -1, Date)
With Worksheets("日付")
For d = sDay To eDay
If IsError(Application.Match(CLng(d), .Columns(1), 0)) Then
With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
.NumberFormatLocal = "yyyy""年""m""月""d""日"""
.Value = d
End With
End If
Next
.Range("A1").CurrentRegion.Sort _
Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
End With
End Sub
（ピンク） 2022/03/27(日) 18:20
1. CLng関数を使用しているのはなぜか。日付には時間まで含まれるから整数に丸めている？
2. myR をVariant型で変数を宣言していますが、myRはどこにも登場しないようですが、どのような意味を持つのでしょうか。
よろしくお願いいたします。
（さくら） 2022/03/27(日) 20:13
>1. CLng関数を使用しているのはなぜか。 MatCh関数を使って日付の検索を行う場合、シリアル値に直す必要があるためです。 https://tech-paclab.com/searchtoday/
>2. myR をVariant型で変数を宣言していますが だだのゴミです。消し忘れていました。
（ピンク） 2022/03/27(日) 20:32
>2. myR をVariant型で変数を宣言していますが
Match関数で日付を検索する場合
Dim myR As Variant
myR = Application.Match(CLng(d), .Columns(1), 0)
この様に使います。
見つかれば myRに行番号が入り。無ければmyRにエラー値が入ります。
この様にmyRには数値、エラー値 何れも格納できるように型はVariantにしております。
myR = Application.Match(CLng(d), .Columns(1), 0)
If IsError(myR) Then
無い場合の処理
Else
見つかった時の処理
End if
今回の場合、行番号は必要なく、有無の判断で良いのでmyRを省き
If IsError(Application.Match(CLng(d), .Columns(1), 0)) Then
となった次第です。(*^_^*)
（ピンク） 2022/03/27(日) 21:08
γ様
アドバイスいただいた事で、沢山の気付きがありました。
ありがとうございました！！
（さくら） 2022/03/27(日) 21:26
もし、日付に時間まで入っていた場合の対応なのですが。例：2022/3/20 12:00:00
同じ日付でも時間違いのものがある場合、matchで比較すると当然エラーになるので、時間を日付のみに変更する作業が必要になってくると思いますが、
ピンク様のコードを参考に、自分なりに下記のように改良してみました。
Sub Test5()
Dim sDay As Date, eDay As Date, d As Date
'★↓↓ここを追加↓↓★
With Worksheets("日付2")
a = Format(.Cells(Rows.Count, "A").End(xlUp).Value, "yyyy/mm/dd")
b = CDate(a)
End With
'★↑↑ここを追加↑↑★
sDay = DateAdd("d", 1, b) '←★ここを変更★
eDay = DateAdd("d", -1, Date)
With Worksheets("日付")
'★↓↓ここを追加↓↓★
Dim 作業列LastRow As Long
作業列LastRow = Cells(Rows.Count, "A").End(xlUp).Row
.Range(.Cells(2, "C"), .Cells(作業列LastRow, "C")).Formula = "=DATEVALUE(TEXT(A2,""yyyy年m月d日""))"
'★↑↑ここを追加↑↑★
For d = sDay To eDay
If IsError(Application.Match(CLng(d), .Columns(3), 0)) Then
With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
.NumberFormatLocal = "yyyy""年""m""月""d""日"""
.Value = d
End With
End If
Next
.Range("A1").CurrentRegion.Sort _
Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
.Columns(3).Delete ' ←★ここを追加★
上記で正しい結果とはなりました。
ただ、考える過程で、今回はC列に作業列を作り日付に変換してからmatchで見比べる方法としましたが、作業列を作らなくても出来たりしますか？例えば下記の.Columns(3)の部分に
Format関数とCDate関数を組み合わせればいくのではないかと試みたもののダメでした。
If IsError(Application.Match(CLng(d), .Columns(3), 0)) Then
何か良いやり方がありましたら教えて下さい。
また、追加の質問になってしまいますが、更に、飛んでいて補填した日付が日曜日だったら×、それ以外なら〇とB列に付けたいのですが、下記のコードとしましたが、これも再度範囲を取り直してループで計算式を追加する方法しか分かりませんでしたが、
matchで見る部分の工程と組み合わせたりすることは可能なものでしょうか？？
'★↓↓ここからは新しい追加作業↓↓★
Dim LastRow再取得 As Long, 再取得範囲 As Long
LastRow再取得 = .Cells(.Rows.Count, "A").End(xlUp).Row
For 再取得範囲 = 2 To LastRow再取得
If .Cells(再取得範囲, 2) = "" Then
.Cells(再取得範囲, "B").Formula = "=IF(Weekday(A" & 再取得範囲 & ")=1,""×"",""〇"")"
End If
Next
End With
End Sub
（さくら） 2022/04/02(土) 09:17
Match関数では無理っぽいのでループで回してみました。
Sub Test2()
Dim sDay As Date, eDay As Date, d As Date
Dim myR As Variant, LastRow As Long, i As Long, flg As Boolean
sDay = CLng(DateAdd("d", 1, Worksheets("日付2").Cells(Rows.Count, "A").End(xlUp).Value))
eDay = DateAdd("d", -1, Date)
With Worksheets("日付")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For d = sDay To eDay
For i = 2 To LastRow
If d = CDate(Int(.Cells(i, "A").Value)) Then
flg = True
Exit For
End If
Next
If flg = False Then
With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
.NumberFormatLocal = "yyyy""年""m""月""d""日"""
.Value = d
.Offset(, 1).Value = IIf(Weekday(d) = 1, "×", "○")
End With
End If
flg = False
Next
.Range("A1").CurrentRegion.Sort _
Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
End With
End Sub
（ピンク） 2022/04/02(土) 10:50
>日付が日曜日だったら×、それ以外なら〇とB列に付けたい 全ての行に付けるのですね
If flg = False Then
With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
.NumberFormatLocal = "yyyy""年""m""月""d""日"""
.Value = d
' .Offset(, 1).Value = IIf(Weekday(d) = 1, "×", "○")
End With
End If
flg = False
Next
.Range("A1").CurrentRegion.Sort _
Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
.Range("B2:B" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = "=IF(WEEKDAY(RC[-1])=1,""×"",""○"")"
End With
End Sub
（ピンク） 2022/04/02(土) 11:08
>For 再取得範囲 = 2 To LastRow再取得 > If .Cells(再取得範囲, 2) = "" Then
これを見る限り追加した行だけでしたね
なら
If flg = False Then
With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
.NumberFormatLocal = "yyyy""年""m""月""d""日"""
.Value = d
.Offset(, 1).Value = IIf(Weekday(d) = 1, "×", "○")
End With
（ピンク） 2022/04/02(土) 11:18
空白は追加した行だけとは限らないのなら
' .Offset(, 1).Value = IIf(Weekday(d) = 1, "×", "○")
End With
End If
flg = False
Next
.Range("A1").CurrentRegion.Sort _
Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
With .Range("B2:B" & .Cells(Rows.Count, "A").End(xlUp).Row)
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=IF(WEEKDAY(RC[-1])=1,""×"",""○"")"
End With
End With
End Sub
（ピンク） 2022/04/02(土) 11:37
Const f As String = "=QUOTIENT(XXXX,1)"
Dim rngOld As Range
Dim rngTemp As Range
Dim dtmStart As Date
Dim dtmEnd As Date
With ThisWorkbook.Worksheets("日付").Range("A1").CurrentRegion
Set rngOld = Intersect(.Offset(0, 0), .Offset(1, 0), .Columns(1))
End With
Set rngTemp = rngOld.Offset(, 5)
With rngTemp
.Formula = Replace(f, "XXXX", rngOld.Cells(1).Address(False, False))
.EntireColumn.NumberFormatLocal = rngOld(1).NumberFormatLocal
End With
With WorksheetFunction
dtmStart = .Max(ThisWorkbook.Worksheets("日付2").Range("A:A")) \ 1 + 1
dtmEnd = .Max(rngTemp) \ 1
End With
With rngTemp(rngTemp.Rows.Count + 1, 1).Resize(dtmEnd - dtmStart + 1)
.Cells(1).Value = dtmStart
.DataSeries Date:=xlDay, Step:=1, Stop:=dtmEnd
End With
With rngTemp.CurrentRegion
.RemoveDuplicates Columns:=1, Header:=xlNo
.SpecialCells(xlCellTypeConstants).Copy
End With
rngOld(rngOld.Rows.Count + 1, 1).PasteSpecial
rngTemp.CurrentRegion.ClearContents
rngOld.CurrentRegion.Sort rngOld, xlAscending, , , , , , xlYes
End Sub
頭の体操＾＾；
意外と長くなった＾＾；
参考になれば。
（まっつわん） 2022/04/02(土) 13:19
まっつわん様
ありがとうございます。
今読み解いているのですが、使用したことのないテクニックが色々ありこちらも勉強になります。
まずは理解できるように頑張ってみたいと思います。
ありがとうございました。
（さくら） 2022/04/02(土) 17:01
>CDate(Int( 〜 の発想や、
If d = CDate(Int(.Cells(i, "A").Value)) Then
↓
If d = DateValue(.Cells(i, "A").Value) Then
お恥ずかしい DateValueでイケました。(*^_^*)
（ピンク） 2022/04/02(土) 18:38
2022/3/24 20:15:00.だとすると、2022/3/26が返る。
2022/3/24 の日付までのデータだと、ちゃんと2022/3/25が返る。
なので、DateAddを省き、
sDay ＝CLng(Worksheets("日付2").Cells(Rows.Count, "A").End(xlUp).Value)としました。
でも、これは時間によって返る値が違ったりして危険なのでしょうか？
色々やっていたら分からなくなってしまい、分かる方いらっしゃいましたら、すみません教えて下さい。
（さくら） 2022/04/04(月) 20:52
>sDay ＝CLng(DateAdd("d", 1, Worksheets("日付2").Cells(Rows.Count, "A").End(xlUp).Value))
>時間まで入っている場合、なぜか ＋２日の日付になってしまいます、、^_^;
If d = DateValue(.Cells(i, "A").Value) Then に修正した時、見落としていました。m(_ _)m
sDay ＝ DateValue(DateAdd("d", 1, Worksheets("日付2").Cells(Rows.Count, "A").End(xlUp).Value))
で如何ですか
（ピンク） 2022/04/04(月) 22:47
If d = DateValue(.Cells(i, "A").Value) Thenに見直した時… ↑今日試した時に、ここでエラーになってしまったので、
Cdate(Int(.Cells(i, "A").Value) Then に戻したのですが、
sDay ＝ DateValue(DateAdd("d", 1, Worksheets("日付2").Cells(Rows.Count, "A").End(xlUp).Value))にすれば
エラーにならなかったのでしょうか？
日付は奥が深いのですね、、色々やってみたいと思います。
また、ネットでCDbl関数で倍精度浮動小数に変換してから、Int関数で整数部分のみを取得という方法も見つけたので、これも試してみたいと思います。
Int(CDbl(〜))
ご丁寧に、ほんとどうもありがとうございます。
（さくら） 2022/04/04(月) 23:00
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.