エクセル２００３ 条件分岐で困っています
いつも回答して頂きとても感謝しています。
Inputboxに検索開始日と検索終了日を入力し、複数のブックにある履歴を1つのシートにまとめたいと思っています。ブックの履歴シートは各月毎に入力されていますが、先月分の履歴も含まれている場合がある為、その履歴シートをそのままつなげていった場合、重複する箇所が発生するため、検索する日付からセル位置（行）を特定して、コピーする領域を設定しようかと思っています。
で、困っている事は検索期間が複数のブックにまたがる時、次のブックの最初の日付をどのように条件分岐させて、『yyyy/m/1』にするかです。色々考えてはいますが、分からない為相談させて頂きました。宜しくお願い致します。
下記が作成中のマクロです。
Sub アラーム履歴一覧作成2()
Dim 開始1 As Date, 開始2 As Date, 開始3 As Date, 開始4 As Date
Dim 終了1 As Date, 終了2 As Date, 終了3 As Date
Dim Path1 As String, Path2 As String
Dim Buf1 As String, Buf2 As String
Dim File As String
Dim wb As Workbook
Dim 日付c As Long
Dim アラームc As Long
Dim 開始r As Long, 終了r As Long
Dim ws1 As Worksheet 'コピー元である引継書のアラーム履歴
Dim ws2 As Worksheet 'コピー先であるファイルのアラーム履歴仮置き場所
On Error GoTo errhandle
開始1 = InputBox("yyyy/mm/dd", "開始日設定画面")
On Error GoTo 0
If 開始1 > Date Then
MsgBox "現在の日付より開始日の方が新しい為検索出来ません。"
Exit Sub
End If
On Error GoTo errhandle
終了1 = InputBox("yyyy/mm/dd", "終了日設定画面")
On Error GoTo 0
If 終了1 > Date Then
MsgBox "現在の日付より終了の日付の方が新しい為検索出来ません。"
Exit Sub
ElseIf 開始1 >= 終了1 Then
MsgBox "現在の日付より終了の日付の方が新しい為検索出来ません。"
Exit Sub
End If
開始2 = 開始1
If Day(開始1) >= Day(終了1) Then
終了2 = DateAdd("m", 1, 終了1)
Else
終了2 = 終了1
End If
Do Until 開始2 >= 終了2
File = "aaa " & Format(開始2, "yyyy年m月")
Path1 = "C:\Users\Owner\Documents\"
Path2 = "C:\Users\Owner\Documents\" & Format(開始2, "yyyy年") & "\"
If Dir(Path1 & File & ".xlsx") <> "" Then
Buf1 = Dir(Path1 & File & ".xlsx")
For Each wb In Workbooks
If wb.Name = Buf1 Then
MsgBox Buf1 & vbCrLf & "はすでに開いています", vbExclamation
Exit Sub
End If
Next wb
Workbooks.Open Filename:=Path1 & File & ".xlsx"
ElseIf Dir(Path2 & File & ".xlsx") <> "" Then
Buf2 = Dir(Path2 & File & ".xlsx")
For Each wb In Workbooks
If wb.Name = Buf2 Then
MsgBox Buf2 & vbCrLf & "はすでに開いています", vbExclamation
Exit Sub
End If
Next wb
Workbooks.Open Filename:=Path2 & File & ".xlsx"
Else
MsgBox (File & "が存在しません！！")
Exit Sub
End If
Set ws1 = Workbooks(File).Worksheets("アラーム履歴")
Set ws2 = Workbooks("アラーム収集").Worksheets("アラーム履歴仮置き")
With ws2.Cells
.ClearContents
ws1.Cells.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
Workbooks(File).Close savechanges:=False
日付c = ws2.Rows(2).Find(what:="発生日時", LookIn:=xlValues, lookat:=xlWhole, _
searchorder:=xlByColumns, searchdirection:=xlNext).Column
ws2.Range("B2:P60000").Sort Key1:=Range("B2"), order1:=xlAscending, Header:=xlYes
日付c = ws2.Rows(2).Find(what:="発生日時", LookIn:=xlValues, lookat:=xlWhole, _
searchorder:=xlByColumns, searchdirection:=xlNext).Column
'ここから先が分からない・・・
開始3 = Format(開始2, "yyyy年m月1日")
終了3 = Format(終了2, "yyyy年m月1日")
If 開始3 = 終了3 Then
開始4 = 開始2
ElseIf 開始3 < 終了3 Then
If 開始3 < 開始2 Then
開始4 = 開始2
Else
開始4 = 開始3
End If
Do While Application.CountIf(ws2.Columns(日付c), 開始4) = 0
If 開始4 < 終了2 Then
開始4 = DateAdd("d", 1, 開始4)
End If
Loop
開始r = ws2.Columns(日付c).Find(what:=開始4, LookIn:=xlFormulas, lookat:=xlWhole, _
searchorder:=xlByRows, searchdirection:=xlNext).Row
開始2 = DateAdd("m", 1, 開始2)
Loop
Exit Sub
errhandle:
MsgBox "日付を打ち込み直して下さい"
End Sub
