[[20210617002029]]　『VBA 日付操作』（sima）　ページの最後に飛ぶ

『VBA 日付操作』（sima）

度々すみません。
日付操作でオーバーフローを起こしてしまい解決できません。

＞Chdate = DateAdd("yyyy", 1, CDate(TargetLD))の部分です。

TargetLDは2020/06/01のように日付が入ります。
１年プラスして2021/06/01に直したいです。
どなたか問題点を教えていただきたいです。
よろしくお願いします。

Dim TargetLD As Date, Chdate As Date, WeekLN As Long

        .Worksheets(1).Range("E:E").Replace "-", "/"
        TargetLD = .Worksheets(1).Cells(i2, "E")
        Chdate = DateAdd("yyyy", 1, CDate(TargetLD))

        If .Worksheets(1).Cells(i2, "AK") <> "F" Then
            wb.Worksheets(1).Cells(s, "A") = .Worksheets(1).Cells(i2, "B")
            wb.Worksheets(1).Cells(s, "B") = .Worksheets(1).Cells(i2, "C")
            wb.Worksheets(1).Cells(s, "C") = .Worksheets(1).Cells(i2, "E")
            wb.Worksheets(1).Cells(s, "D") = .Worksheets(1).Cells(i2, "Z")
            wb.Worksheets(1).Cells(s, "E") = .Worksheets(1).Cells(i2, "AA")
            wb.Worksheets(1).Cells(s, "G") = Chdate
            TargetLD = wb.Worksheets(1).Cells(s, "G")
            WeekLN = DatePart("ww", TargetLD, vbMonday) - DatePart("ww", DateSerial(Year(TargetLD), Month(TargetLD), 1), vbMonday) + 1
            wb.Worksheets(1).Cells(s, "F") = WeekLN
            s = s + 1
        End If

＜使用 Excel：Office365、使用 OS：MacOSX ＞

 >TargetLD = .Worksheets(1).Cells(i2, "E")
 セル E2 の値を変数 TargetLD に代入するのに
 Cells(i2, "E")はどうして i2 にしてるんですかね。
 ただの 2 だけでいいのでは？
 以降も i2 になっているので要注意。
 違っていたらごめんなさいね。
 あと気になるのが s です。

（PP） 2021/06/17(木) 07:14

説明が不十分ですいませんでした。
下記がプロシージャです。
Last Year から下が上手く動きません。
Date型に代入する複数箇所でオーバーフローしてしまします。
＞TargetLDp = .Worksheets(1).Cells(i2, "E")で代入した年の１年プラスしたものの週番号を転記したいです。
よろしくお願いします。

Sub ThisYear()

    fname = Application.GetOpenFilename
    If fname <> False Then Range("D7") = fname
End Sub

Sub LastYear()

    fname = Application.GetOpenFilename
    If fname <> False Then Range("D10") = fname
End Sub

Sub TwoYearsAgo()

    fname = Application.GetOpenFilename
    If fname <> False Then Range("D13") = fname
End Sub

Sub Work()

'This Year

Dim Ty As String, Ly As String, Tya As String, wb As Workbook

    Ty = Range("D7")
    Ly = Range("D10")
    Tya = Range("D13")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Workbooks.Add
    Set wb = ActiveWorkbook

    Dim MaxRowT As Long, s As Long, i As Long

    With Workbooks.Open(FileName:=Ty)
    MaxRowT = .Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    s = 1
    i = 2

    Do Until i > MaxRowT
        If .Worksheets(1).Cells(i, "AB") = "REVERSED" Then
            .Worksheets(1).Cells(i, "AK") = "F"
        End If
        If .Worksheets(1).Cells(i, "AD") <> "" Then
            .Worksheets(1).Cells(i, "AK") = "F"
        End If
        If .Worksheets(1).Cells(i, "AC") = "催事" Then
            .Worksheets(1).Cells(i, "AK") = "F"
        End If
        If .Worksheets(1).Cells(i, "C") = "0801100" Then
            On Error Resume Next
             .Worksheets(1).Cells(i, "AK") = WorksheetFunction.VLookup(.Worksheets(1).Cells(i, "B"), .Worksheets(2).Range("A:A"), 1, 0)
             If .Worksheets(1).Cells(i, "AK") <> "" Then
             .Worksheets(1).Cells(i, "AK") = "F"
             End If
        End If
            On Error GoTo 0

        Dim TargetD As Date, WeekN As Long

        .Worksheets(1).Range("E:E").Replace "-", "/"
        TargetD = .Worksheets(1).Cells(i, "E")
        WeekN = DatePart("ww", TargetD, vbMonday) - DatePart("ww", DateSerial(Year(TargetD), Month(TargetD), 1), vbMonday) + 1
        .Worksheets(1).Cells(i, "AL") = WeekN

        If .Worksheets(1).Cells(i, "AK") <> "F" Then
            wb.Worksheets(1).Cells(s, "A") = .Worksheets(1).Cells(i, "B")
            wb.Worksheets(1).Cells(s, "B") = .Worksheets(1).Cells(i, "C")
            wb.Worksheets(1).Cells(s, "C") = .Worksheets(1).Cells(i, "E")
            wb.Worksheets(1).Cells(s, "D") = .Worksheets(1).Cells(i, "Z")
            wb.Worksheets(1).Cells(s, "E") = .Worksheets(1).Cells(i, "AA")
            wb.Worksheets(1).Cells(s, "F") = .Worksheets(1).Cells(i, "AL")
            s = s + 1
        End If

    i = i + 1
    Loop
        .Close
    End With

    'Last year

    Dim i2 As Long, MaxRowL As Long

    With Workbooks.Open(FileName:=Ly)
    MaxRowL = .Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

    i2 = 2
    Do Until 2 > MaxRowL
        If .Worksheets(1).Cells(i2, "AB") = "REVERSED" Then
            .Worksheets(1).Cells(i2, "AK") = "F"
        End If
        If .Worksheets(1).Cells(i2, "AD") <> "" Then
            .Worksheets(1).Cells(i2, "AK") = "F"
        End If
        If .Worksheets(1).Cells(i2, "AC") = "催事" Then
            .Worksheets(1).Cells(i2, "AK") = "F"
        End If
        If .Worksheets(1).Cells(i2, "C") = "0801100" Then
            On Error Resume Next
             .Worksheets(1).Cells(i2, "AK") = WorksheetFunction.VLookup(.Worksheets(1).Cells(i2, "B"), .Worksheets(2).Range("A:A"), 1, 0)
             If .Worksheets(1).Cells(i2, "AK") <> "" Then
             .Worksheets(1).Cells(i2, "AK") = "F"
             End If
            On Error GoTo 0
        End If

        Dim TargetLD As Date, Chdate As Date, WeekLN As Long, TargetLDp As Date

        .Worksheets(1).Range("E:E").Replace "-", "/"
        TargetLDp = .Worksheets(1).Cells(i2, "E")
        Chdate = DateAdd("yyyy", 1, CDate(TargetLDp))

        If .Worksheets(1).Cells(i2, "AK") <> "F" Then
            wb.Worksheets(1).Cells(s, "A") = .Worksheets(1).Cells(i2, "B")
            wb.Worksheets(1).Cells(s, "B") = .Worksheets(1).Cells(i2, "C")
            wb.Worksheets(1).Cells(s, "C") = .Worksheets(1).Cells(i2, "E")
            wb.Worksheets(1).Cells(s, "D") = .Worksheets(1).Cells(i2, "Z")
            wb.Worksheets(1).Cells(s, "E") = .Worksheets(1).Cells(i2, "AA")
            wb.Worksheets(1).Cells(s, "G") = TargetLDp
            TargetLD = wb.Worksheets(1).Cells(s, "G")
            WeekLN = DatePart("ww", TargetLD, vbMonday) - DatePart("ww", DateSerial(Year(TargetLD), Month(TargetLD), 1), vbMonday) + 1
            wb.Worksheets(1).Cells(s, "F") = WeekLN
            s = s + 1
        End If

    i2 = i2 + 1
    Loop
        .Close
    End With

（sima） 2021/06/17(木) 08:33

Do Until 2 > MaxRowL
この脱出条件はいつになったら成立しますか？
無限に続いていませんか？

（確認） 2021/06/17(木) 08:49

こういうことも起きがちなので、Do Loopはやめて
For .. Nextを使うことを推奨します。
Do Loopは予め脱出するタイミングが見通せない時に使うべきです。
この場合は、最終行までと明確なのですから、For .. Nextを使いましょう。
For .. Nextは無限ループになる危険はありません。
（確認） 2021/06/17(木) 09:40

ありがとうございます。
For..Nextに変更し無限ループがなくなりました。
転記されるようにはなったのですが、1年プラスされて転記がされません。
＞Chdate = DateAdd("yyyy", 1, CDate(TargetLDp))
デバックしてもこの部分でオーバーフローしてしまいます。
原因わかりますでしょうか？
よろしくお願いします。
（sima） 2021/06/17(木) 10:33

 その時点でTargetLDpは何になっていますか。
（namn） 2021/06/17(木) 10:50

ありがとうございます。
TargetLDpは2020/10/01のような日付が代入されてます。
（sima） 2021/06/17(木) 11:07

 さらにエラー発生の時点で、
 イミティエイトウィンドウで
 ?DateAdd("yyyy", 1, CDate(TargetLDp))
 ?DateAdd("yyyy", 1, CDate("2020/10/01"))
 それぞれ実行してみて、エラーになりますか。
（namn） 2021/06/17(木) 11:18

関係ないかもしれないけど、TargetLDpはDate型だから、CDateで変換する必要ないんじゃないでしょうか？

    Sub 実験用()
        Dim TargetLDp As Date
        TargetLDp = DateValue("2021-6-17")
        Debug.Print DateAdd("yyyy", 1, CDate(TargetLDp))
        Debug.Print DateAdd("yyyy", 1, TargetLDp)
    End Sub

（もこな２） 2021/06/17(木) 13:21

@namnさん
両方試しましたがオーバーフローになってしまいます。

@もなこ２さん
こちらもオーバーフローになってしまいます。。
（sima） 2021/06/17(木) 14:27

＞@もなこ２さん
たぶん私あてだとおものですが、ちょっと例示が良くなかったです。

    Sub 実験用()
        Dim TargetLDp As Date
        TargetLDp = DateValue("2021-6-17")
        On Error Resume Next
        Debug.Print DateAdd("yyyy", 1, CDate(TargetLDp))
        Debug.Print DateAdd("yyyy", 1, TargetLDp)
        On Error GoTo 0
    End Sub

要は「CDate」いらないよね?ってことがお伝えしたかったことです。

（もこな２） 2021/06/17(木) 15:51

Debug.Print TargetLDp
Chdate = DateAdd("yyyy", 1, CDate(TargetLDp))
Debug.Print Chdate
などとして、事態をきちんと確認するのが、まずはすべきことでは？

ところで、
＞Chdate = DateAdd("yyyy", 1, CDate(TargetLDp))
で作られたChdateはどこでも使われていないように見えますが、どうなんですか？
本当にそこでエラーが発生しているんですか？
無限ループの時も、あらぬ疑いを掛けられていたようですが。
（γ） 2021/06/17(木) 16:50

■１
提示のコードを部分的に改造（整理）すると、おそらく↓のようになろうかとおもいます。

    Sub Work_改造()
        Dim Ty As String, wb As Workbook
        Dim s As Long, i As Long
        Dim TargetD As Date

        With ActiveSheet
            Ty = .Range("D7").Value
        End With

        Set wb = Workbooks.Add
        With Workbooks.Open(Filename:=Ty).Worksheets(1)
            s = 1
            For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row Step 1

                'AB列が"REVERSED"　or AD列が""でない or AC列が"催事"　→AK列に"F"と入力
                If .Cells(i, "AB").Value = "REVERSED" Or _
                   .Cells(i, "AD").Value <> "" Or _
                   .Cells(i, "AC").Value = "催事" Then

                   .Cells(i, "AK").Value = "F"
                End If

                'C列の値が"0801100" and B列の値が２番目シートのA列にあれば　→AK列に"F"と入力
                If .Cells(i, "C").Value = "0801100" And WorksheetFunction.CountIf(.Cells(i, "B").Value, .Parent.Worksheets(2).Range("A:A")) > 0 Then
                    .Cells(i, "AK").Value = "F"
                End If

                'E列の値を日付型として取得して、月頭から何週目かをAL列に出力
                TargetD = DateValue(.Cells(i, "E").Value)
                .Cells(i, "AL").Value = DatePart("ww", TargetD, vbMonday) - DatePart("ww", DateSerial(Year(TargetD), Month(TargetD), 1), vbMonday) + 1

                If .Cells(i, "AK") <> "F" Then
                    wb.Worksheets(1).Cells(s, "A").Value = .Cells(i, "B").Value
                    wb.Worksheets(1).Cells(s, "B").Value = .Cells(i, "C").Value
                    wb.Worksheets(1).Cells(s, "C").Value = .Cells(i, "E").Value
                    wb.Worksheets(1).Cells(s, "D").Value = .Cells(i, "Z").Value
                    wb.Worksheets(1).Cells(s, "E").Value = .Cells(i, "AA").Value
                    wb.Worksheets(1).Cells(s, "F").Value = .Cells(i, "AL").Value
                    s = s + 1
                End If
            Next i

            .Parent.Close False
        End With
    End Sub

■２
上記を踏まえると、
開いたブックの１番目のシートのデータを整理していき、最後までAF列にフラグ（"F"）が立たなかったものだけ、新規ブックに出力したいという話ですよね。たぶん。

その観点でみると、データ元の

 AB列が"REVERSED"でないこと
 AD列が""であること
 AC列が"催事"でないこと
 C列の値が"0801100"でないこと
 B列の値が２番目シートのA列にないこと

という条件を満たした【行】だけコピー（転記）すればよいのではありませんか？

■３
現在悩まれている「何週目」を出力する部分は、コピー（転記）された後に処理すればよく、転記対象であるか判定する部分に入れ込むのは適切ではないと思います。
（転記対象じゃないデータの何週目を求めたところで無駄なので）

よって、お悩みのところは一旦おいておいて、転記処理と何週目の算出？は別処理にしたらどうでしょうか？
（案外、エラーになる部分は処理の必要が無い部分かもしれませんし・・・・）

例えばこんな感じです。

    Sub さんぷる()
        Dim Ty As String, Ly As String
        Dim dstRNG As Range
        Dim i As Long

        With ActiveSheet
            Ty = .Range("D7").Value
            Ly = .Range("D10").Value
        End With

        '▼転記処理は別ルーチンで処理
        Set dstRNG = Workbooks.Add.Worksheets(1).Range("B2")
        Call 転記処理(Ty, dstRNG)
        Call 転記処理(Ly, dstRNG)

        '▼転記したものだけ何週目か算出する処理（D10セルのファイル由来のものは、追加でG列に日付データを書き込み）
        With dstRNG.Parent
            For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
                .Cells(i, "F").Value = DatePart("ww", DateValue(.Cells(i, "C").Value), vbMonday) - DatePart("ww", DateSerial(Year(DateValue(.Cells(i, "C").Value)), Month(DateValue(.Cells(i, "C").Value)), 1), vbMonday) + 1
                If .Cells(i, "A").Value = Ly Then .Cells(i, "G").Value = DateValue(.Cells(i, "C").Value)
            Next i
        End With
    End Sub
    '==========================================================================
    Sub 転記処理(ファイルパス As String, dstRNG As Range)
        Dim i As Long
        Dim bufRNG As Range

        ファイルパス = ActiveSheet.Range("D7").Value
        With Workbooks.Open(Filename:=ファイルパス).Worksheets(1)

            For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row Step 1
                Select Case True
                    Case .Cells(i, "AB").Value = "REVERSED"
                    Case .Cells(i, "AC").Value = "催事"
                    Case .Cells(i, "AD").Value <> ""
                    Case .Cells(i, "C").Value = "0801100" And WorksheetFunction.CountIf(.Parent.Worksheets(2).Range("A:A"), .Cells(i, "B").Value) > 0

                    '▼↑の【いずれも満たさない】場合に処理(その行を覚える）
                    Case Else
                        If bufRNG Is Nothing Then
                            Set bufRNG = .Rows(i)
                        Else
                            Set bufRNG = Union(bufRNG, .Rows(i))
                        End If
                End Select
            Next i

            '▼覚えた行があれば処理（コピーして値貼り付け）
            If Not bufRNG Is Nothing Then
                Intersect(bufRNG, .Range("B:C,E:E,Z:AA")).Copy
                dstRNG.PasteSpecial Paste:=xlPasteValues
                dstRNG.Offset(, -1).Resize(bufRNG.Rows.Count).Value = ファイルパス
                Set dstRNG = dstRNG.Offset(bufRNG.Rows.Count)
            End If

            .Parent.Close False
        End With
    End Sub

（もこな２） 2021/06/17(木) 17:46

 なんとなく、Windowsの日付表示を日本語表記にしてませんかね？
 特に短い方。
 してないのならスルーして結構。
（BJ） 2021/06/17(木) 18:39

 ↑
 日本語表記と言う表現は適切ではなかった。
 自分のPCは、日本語形式になってた。(右下の日付)
 コントロールパネルの地域と言語の方をいじってないですかね？

 というか、分解して自分で確認するって事はしないのでしょうね。
 聞けば良いから・・・。
 実際、TargetLD の中身を書きだして確認とかしないのかな？

（BJ） 2021/06/17(木) 18:51

@γさん
おっしゃる通りでした。
単純なミスでした。
wb.Worksheets(1).Cells(s, "G") = TargetLDp
↓
wb.Worksheets(1).Cells(s, "G") = Chdate
に変更したら転記できました！

＠もこな２さん
サンプルありがとうございました！
早速勉強して取り入れたいと思います！

アドバイスをくださった皆様、ありがとうございました！
（sima） 2021/06/17(木) 19:19

解決したようですが、ちょっとミスがあったので訂正。

「転記処理」の↓は要らなかったので、試すなら削除してからにしてください。

 ファイルパス = ActiveSheet.Range("D7").Value

（もこな２） 2021/06/17(木) 19:31

結局、エラーはどこで発生していたのですか？
なにか釈然としませんね。
もう少し説明が必要では？

（γ） 2021/06/17(木) 19:39

| Debug.Print TargetLDp
| Chdate = DateAdd("yyyy", 1, CDate(TargetLDp))
| Debug.Print Chdate
| などとして、事態をきちんと確認するのが、まずはすべきことでは？
この結果はどうだったのでしょうか。
DateAdd自体は正常動作していたのか、
何が原因だったのか、きちんと説明してください。

転記元が間違いというのとはまったく別の話だったはずです。
皆さん、色々な可能性を考えてコメントして下さっているわけですから、
きちんと結果を教えてください。
こんな感じでうやむやにされるなら、次回からは放置？されますよ。
（ま、言い過ぎか、それくらいの気持ちということです）

（γ） 2021/06/17(木) 19:51

＠もこな２さん
承知しました。ありがとうございます。

＠γさん
おっしゃる通りです。
説明が足らず失礼しました。

みなさま

＞
Debug.Print TargetLDp
Chdate = DateAdd("yyyy", 1, CDate(TargetLDp))
Debug.Print Chdate

これらを試しましたが、正しく動作しておりました。
1 For..Next に修正して無限ループから脱出
2 wb.Worksheets(1).Cells(s, "G") = TargetLDp → wb.Worksheets(1).Cells(s, "G") = Chdate
に転記もとを修正
以上で解決しました。

大変お騒がせしました。
今回Debug.Printのやり方を教えていただいたので
エラーを見つけることができました。

みなさま、本当にありがとうございました。
（sima） 2021/06/17(木) 20:56

最初の質問と全く関係ない方に進んで、全く関係ない所で解決しました。
ですか、全く解りませんな。
あまり相手にしたくない人種ですな。
（摩訶不思議） 2021/06/17(木) 21:39

 コードを作成したとき、それがエラー無しに想定どおり動くことは珍しいことなんです。
 大抵は、なにかしら想定と異なることが起きるのは普通のことです。
 その時、こうした場に質問するより前に、デバッグ（間違いの確認・修正）を
 ご自分でしてみることが必要です。
 「デバッグ」はコード作成と不即不離の重要な要素です。
 そのあたりをよく理解してください。

 デバッグ手法については、例えば、
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030.html
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030_03.html
 などを読まれることをお薦めします。

 （以下に数行書きましたが、これも当方の勝手な読みかもしれないので、
   削除します。
   スタックオーバーフローしていて、関数の実行もできない状態だった
   可能性もある。）←　23:20 数行を削除しました。

（γ） 2021/06/17(木) 22:24

デバッグのリンクをありがとうございます。
こちらも説明が足らずにすみません。
仕様覧にチェックを入れたと思うのですが。不本意ながらMacを使用しております。
Mac 特有のエラーらしいのですが、プロシージャが正しくても、ブレークポイントを入れるとオーバーフローしてしまうことが稀に起きてしまいます。
以前も正しい割り算のコードを書いたにも関わらず、ブレークポイントを入れることでオーバーフロー起こしおりました。
今回も教えていただいたDebug.Print は実際に全て試しましたが、ブレークポイントを入れてデバッグしていましたので、問題箇所の特定に時間がかかってしまいました。
ブレークポイントとDebug.Printは同時に使用するものだと思っておりました。
皆様の貴重な時間を無駄にしてしまったことは大変申し訳なく思います。
今後はデバッグの勉強も致します。
本当にすみませんでした。
（sima） 2021/06/17(木) 23:02

 いやあmacですか、見逃してました。というかこれは知りませんでした。
 Mac版 Microsoft365 ExcelのVBAでブレークポイントを張るとCDateでオーバーフローする
https://answers.microsoft.com/ja-jp/msoffice/forum/all/mac%E7%89%88-microsoft365/b7d20f33-6cca-4ba6-8296-353bba88252d

（namn） 2021/06/18(金) 11:22

ここで教えていただいたプロシージャを勉強しながら取り入れているのですが
どうしても解決できない箇所があり教えていただきたいです。

dstRNG.Offset(, -1).Resize(bufRNG.Rows.Count).Value = ファイルパス
Set dstRNG = dstRNG.Offset(bufRNG.Rows.Count)

↑本来教えていただいたこの部分、最終行の取得に失敗してしまうため、下記に書き直して見ました。
（callの使い方もいまいちわからずアレンジしてます）

（問題点）
２段目last yearのプロシージャ
maxLow2 = dstRNG.Cells(.Rows.Count, 2).End(xlUp).Row
この箇所でエラー1004 rangeメソッド失敗となります。
デバッグしましたが、やはり最終行が取れてないみたいです。
ただ、その先の解決方法がわかりません。
よろしくお願いします。

Sub Work()

'This Year

Dim Ty As String, Ly As String, Tya As String, wb As Workbook, dstRNG As Range

Ty = Range("D7")
Ly = Range("D10")
Tya = Range("D13")

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set dstRNG = Workbooks.Add.Worksheets(1).Range("B1")

Dim i As Long, bufRNG As Range, maxLow As Long

With Workbooks.Open(FileName:=Ty).Worksheets(1)

    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
        Select Case True
            Case .Cells(i, "AB").Value = "REVERSED"
            Case .Cells(i, "AC").Value = "催事"
            Case .Cells(i, "AD").Value <> ""
            Case .Cells(i, "C").Value = "0801100" And WorksheetFunction.CountIf(.Parent.Worksheets(2).Range("A:A"), Cells(i, "B").Value) > 0

            Case Else
                If bufRNG Is Nothing Then
                    Set bufRNG = .Rows(i)
                Else
                    Set bufRNG = Union(bufRNG, .Rows(i))
                End If
        End Select
    Next i

    If Not bufRNG Is Nothing Then
        Intersect(bufRNG, .Range("B:C,E:E,Z:AA")).Copy
        dstRNG.PasteSpecial Paste:=xlPasteValues
        maxLow = dstRNG.Cells(.Rows.Count, 1).End(xlUp).Row
        Set dstRNG = dstRNG.Cells(maxLow, 1).Offset(1)
    End If
Set bufRNG = Nothing
maxLow = 0
.Parent.Close False
End With

 'Last year

Dim i2 As Long, maxLow2 As Long

With Workbooks.Open(FileName:=Ly).Worksheets(1)

    For i2 = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
        Select Case True
            Case .Cells(i2, "AB").Value = "REVERSED"
            Case .Cells(i2, "AC").Value = "催事"
            Case .Cells(i2, "AD").Value <> ""
            Case .Cells(i2, "C").Value = "0801100" And WorksheetFunction.CountIf(.Parent.Worksheets(2).Range("A:A"), Cells(i2, "B").Value) > 0

            Case Else
                If bufRNG Is Nothing Then
                    Set bufRNG = .Rows(i2)
                Else
                    Set bufRNG = Union(bufRNG, .Rows(i2))
                End If
        End Select
    Next i2

    If Not bufRNG Is Nothing Then
        Intersect(bufRNG, .Range("B:C,E:E,Z:AA")).Copy
        dstRNG.PasteSpecial Paste:=xlPasteValues
        maxLow2 = dstRNG.Cells(.Rows.Count, 2).End(xlUp).Row
        Set dstRNG = dstRNG.Cells(maxLow2, 1).Offset(1)
    End If
Set bufRNG = Nothing
End With

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
････…………
（sima） 2021/06/23(水) 01:30

maxLow2 = dstRNG.Cells(.Rows.Count, 2).End(xlUp).Row
でエラーになるのは、例えば、

maxLow2 = Range("B3").Cells(Rows.Count, 2).End(xlUp).Row
がエラーになるのと同じです。
Range("B3").Cells(Rows.Count, 2)が、
ワークシートの最下行を突き抜けるからです。

そもそも、B列の最下行を得るなら、
maxLow2 = ワークシート.Cells(Rows.Count, 2).End(xlUp).Row
じゃないんですか？

（γ） 2021/06/23(水) 07:17

γさん

おっしゃる通りでした。
dstRNGを下記のようにワークシートに変更したら解決しました。
ありがとうございました！

Sub Work()

'This Year

Dim Ty As String, Ly As String, Tya As String, wb As Workbook, dstRNG As Workbook

Ty = Range("D7")
Ly = Range("D10")
Tya = Range("D13")

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set dstRNG = Workbooks.Add

Dim i As Long, bufRNG As Range, maxLow As Long, dstRNGC As Range

With Workbooks.Open(FileName:=Ty).Worksheets(1)

    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
        Select Case True
            Case .Cells(i, "AB").Value = "REVERSED"
            Case .Cells(i, "AC").Value = "催事"
            Case .Cells(i, "AD").Value <> ""
            Case .Cells(i, "C").Value = "0801100" And WorksheetFunction.CountIf(.Parent.Worksheets(2).Range("A:A"), Cells(i, "B").Value) > 0

            Case Else
                If bufRNG Is Nothing Then
                    Set bufRNG = .Rows(i)
                Else
                    Set bufRNG = Union(bufRNG, .Rows(i))
                End If
        End Select
    Next i

    If Not bufRNG Is Nothing Then
        Intersect(bufRNG, .Range("B:C,E:E,Z:AA")).Copy
        dstRNG.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
        maxLow = dstRNG.Worksheets(1).Cells(.Rows.Count, 1).End(xlUp).Row
        Set dstRNGC = dstRNG.Worksheets(1).Cells(maxLow + 1, 1)
    End If
Set bufRNG = Nothing
.Parent.Close False
End With

    'Last year
Dim i2 As Long, maxLow2 As Long, dstRNGC2 As Range

With Workbooks.Open(FileName:=Ly).Worksheets(1)

    For i2 = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
        Select Case True
            Case .Cells(i2, "AB").Value = "REVERSED"
            Case .Cells(i2, "AC").Value = "催事"
            Case .Cells(i2, "AD").Value <> ""
            Case .Cells(i2, "C").Value = "0801100" And WorksheetFunction.CountIf(.Parent.Worksheets(2).Range("A:A"), Cells(i2, "B").Value) > 0

            Case Else
                If bufRNG Is Nothing Then
                    Set bufRNG = .Rows(i2)
                Else
                    Set bufRNG = Union(bufRNG, .Rows(i2))
                End If
        End Select
    Next i2

    If Not bufRNG Is Nothing Then
        Intersect(bufRNG, .Range("B:C,E:E,Z:AA")).Copy
        dstRNGC.PasteSpecial Paste:=xlPasteValues
        maxLow2 = dstRNG.Worksheets(1).Cells(.Rows.Count, 1).End(xlUp).Row
        Set dstRNGC2 = dstRNG.Worksheets(1).Cells(maxLow2 + 1, 1)
    End If
Set bufRNG = Nothing
.Parent.Close False
End With

'Tya
Dim i3 As Long

With Workbooks.Open(FileName:=Tya).Worksheets(1)
For i3 = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row

    Select Case True
        Case .Cells(i3, "AB").Value = "REVERSED"
        Case .Cells(i3, "AC").Value = "催事"
        Case .Cells(i3, "AD").Value <> ""
        Case .Cells(i3, "C").Value = "0801100" And WorksheetFunction.CountIf(.Parent.Worksheets(2).Range("A:A"), Cells(i3, "B").Value) > 0

        Case Else
            If bufRNG Is Nothing Then
                Set bufRNG = .Rows(i3)
            Else
                Set bufRNG = Union(bufRNG, .Rows(i3))
            End If
    End Select
Next i3

If Not bufRNG Is Nothing Then

   Intersect(bufRNG, .Range("B:C,E:E,Z:AA")).Copy
   dstRNGC2.PasteSpecial Paste:=xlPasteValues
End If
.Parent.Close False
End With
（sima） 2021/06/23(水) 08:57

結果が出ているのであればそれはそれで結構かと思います。
すこし気づいた細かい点。
1. dstRNGという変数名が「名は体を表していない」気がします。
　　あとあと、はてなということになりませんか？
2. そのブック.Worksheets(1) をワークシート変数にしたほうがよいのでは？
3. 次の作業の貼付先を前もって準備する方式のようですが、
　　コピーする直前で、貼付先を
　　Set rngTo = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1)
　　などとする方法もあるでしょう。

（γ） 2021/06/23(水) 19:44

なるほどですね。
全てその通りだと思います。
コードを書くので手一杯でした。
すこし整理してみます。
ありがとうございました！
（sima） 2021/06/23(水) 21:24

本筋は解決してるようなので、思ったことなど。

■４
実質的には↓は同じ処理なわけですから、何回も書くのではなく繰り返し（ループ処理）にするのがメンテナンスの面からみても有利だと思います。

 1)ブックを開く
 2)コピー対象をピックアップする
 3)↑を出力先にコピペする
 4)ブックを開く

さらには、ブックのパスが書いてあるセルは、D7、D10、D13と３列ずつ規則的にずれているのですから、まさに繰り返し処理に向いていると言えるでしょう。

■５
（mac版はちがうのかもしれませんが）標準モジュールで「Range("D7")」のように書くと、「ActiveSheet.Range("D7")」のようにアクティブシートを指定したものとみなされます。
今回の場合は影響ないでしょうが、複数のブックやシートを扱うのであれば、ちゃんとどのブックのどのシートなのか指定（オブジェクト修飾）したほうがよいとおもいます。

■６
γさんがコメントされているように、私が提示したものは、次の貼り付け作業のために、出力先のセルを【コピーした行数分下にずらす】ことをしています。

これは、コピー対象のレイアウトがわからなかったのでそうしたまでです。
↓で最終行を求めることができる（つまりB列を調べれば最終行が取得できる）ことが確定しているならば、貼り付け時に直接指定することも可能です。

 maxLow2 = シートオブジェクト.Cells(.Rows.Count, 2).End(xlUp).Row

■７
ということを踏まえると、↓のような感じでもよいように思います。

    Option Explicit
    Sub Work_改()
        Dim srcWB As Workbook, srcRNG As Range
        Dim dstSH As Worksheet
        Dim c As Long, i As Long

        'Application.ScreenUpdating = False
        'Application.DisplayAlerts = False

        With ActiveSheet
            Set dstSH = Workbooks.Add.Worksheets(1)

             For c = 7 To 13 Step 3
                Set srcWB = Workbooks.Open(.Cells(c, "D").Value)
                Set srcRNG = Nothing

                '▼条件にあう行（コピー対象のセル）をピックアップする処理
                With srcWB.Worksheets(1)
                    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                        Select Case True
                            Case .Cells(i, "AB").Value = "REVERSED"
                            Case .Cells(i, "AC").Value = "催事"
                            Case .Cells(i, "AD").Value <> ""
                            Case .Cells(i, "C").Value = "0801100" And WorksheetFunction.CountIf(srcWB.Worksheets(2).Range("A:A"), .Cells(i, "B").Value) > 0

                            Case Else
                                If srcRNG Is Nothing Then
                                    Set srcRNG = Intersect(.Rows(i), .Range("B:C,E:E,Z:AA"))
                                Else
                                    Set srcRNG = Union(srcRNG, Intersect(.Rows(i), .Range("B:C,E:E,Z:AA")))
                                End If
                        End Select
                    Next i
                End With

                '▼ピックアップした行があれば出力（コピペ）する処理
                If Not srcRNG Is Nothing Then
                    srcRNG.Copy dstSH.Cells(dstSH.Rows.Count, "B").End(xlUp).Offset(1)
                End If

                srcWB.Close False

            Next c
        End With

        If dstSH.Range("B1").Value = "" Then dstSH.Rows(1).Delete

    End Sub

（もこな２） 2021/06/24(木) 12:19

なるほどですね。
いつもサンプルを教えていただき、とても勉強になります!
明日時間がある時に、勉強がてらまた参考にしたいと思います。
ありがとうございました！
（sima） 2021/06/24(木) 19:08

コメント返信：

[ 一覧(最新更新順) ]

[[20210617002029]] 『VBA 日付操作』（sima） ページの最後に飛ぶ

[[20210617002029]]　『VBA 日付操作』（sima）　ページの最後に飛ぶ