雑誌バックナンバー検索の条件判断と抽出実行のVBA

Option Explicit
    Public fdatey As Variant
    Public tdatey As Variant
    Public fdatem As Variant
    Public tdatem As Variant
    Public fdated As Variant
    Public tdated As Variant
    Public myKEY As Variant
    Public myKEYb As Variant
    Public Krow As Long
    Public Drow As Long
    Dim Y As Long
    Dim M As Long
    Dim D As Long
    Dim Check As String

Sub 雑誌名検索()
    Dim Tc As Range
    Dim Tcs As Range
    Dim myRange As Range
    Dim Frow As Long
    Dim i , n , H As Long
        Call Module2.検索結果クリア
'検索結果シートに見出しを貼り付け
        With Worksheets("データまとめ")
            .Range("A1", "L1").Copy _
                    Destination:=Worksheets("検索結果").Range("A1")
            .Select
            Drow = .Range("B1").CurrentRegion.Rows.Count
        End With
        Set myRange = Range("I2", "I" & Drow)
'雑誌名を検索
        H = 2
        Set Tc = myRange.Find(myKEY, LookIn:=xlValues, _
                            LookAt:=xlPart, MatchByte:=False)
        If Tc Is Nothing Then
            Worksheets("検索結果").Select
            MsgBox "「" & myKEY & "」はありませんでした", vbExclamation, _
                        "バックナンバー検索"
            Exit Sub
            Call Module2.検索結果クリア
        End If
        Frow = Tc.Row
        Set Tcs = Tc
        Do
            Worksheets("データまとめ") _
                .Range("A" & Tcs.Row, "L" & Tcs.Row).Copy _
                    Destination:=Worksheets("検索結果").Range("A" & H)
            Set Tcs = myRange.FindNext(Tcs)
            If Tcs Is Nothing Then Exit Do
            H = H + 1
        Loop Until Tcs.Row = Frow
'検索結果を一旦整理
        Worksheets("検索結果").Select
        Krow = Range("B1").CurrentRegion.Rows.Count
        n = 1
        For i = 2 To Krow
            Range("A" & i) = n
            n = n + 1
        Next i
'期間設定条件を加味する
        Call Module2.期間設定
        Application.CutCopyMode = False
        Call Module1.シート体裁
                If Worksheets("検索結果").Range("B2") = "" Then
            MsgBox "該当する検索結果はありません。", vbExclamation, _
                        "バックナンバー検索"
        Else
            MsgBox "検索結果を表示しました。", vbInformation, _
                        "バックナンバー検索"
        End If
End Sub

Sub 雑誌NO検索()
    Dim Tcb As Range
    Dim Tcsb As Range
    Dim myRangeb As Range
    Dim Frowb As Long
    Dim i As Long, n As Long
        Call Module2.検索結果クリア
'検索結果シートに見出しを貼り付け
        With Worksheets("データまとめ")
            .Range("A1", "L1").Copy _
                Destination:=Worksheets("検索結果").Range("A1")
            .Select
            Drow = .Range("B1").CurrentRegion.Rows.Count
        End With
        Set myRangeb = Range("D2", "D" & Drow)
'雑誌コードを検索
        H = 2
        Set Tcb = myRangeb.Find(myKEYb, LookIn:=xlValues, _
                                LookAt:=xlWhole, MatchByte:=False)
        If Tcb Is Nothing Then
            Worksheets("検索結果").Select
            MsgBox "「" & myKEYb & "」はありませんでした", vbExclamation, _
                        "バックナンバー検索"
            Exit Sub
            Call Module2.検索結果クリア
        End If
        Frowb = Tcb.Row
        Set Tcsb = Tcb
        Do
            Worksheets("データまとめ") _
                .Range("A" & Tcsb.Row, "L" & Tcsb.Row).Copy _
                    Destination:=Worksheets("検索結果").Range("A" & H)
            Set Tcsb = myRangeb.FindNext(Tcsb)
            If Tcsb Is Nothing Then Exit Do
            H = H + 1
        Loop Until Tcsb.Row = Frowb
'検索結果を一旦整理
        Worksheets("検索結果").Select
        Krow = Range("B1").CurrentRegion.Rows.Count
        n = 1
        For i = 2 To Krow
            Range("A" & i) = n
            n = n + 1
        Next i
'期間設定条件を加味する
        Call Module2.期間設定
        Application.CutCopyMode = False
        Call Module1.シート体裁
        If Worksheets("検索結果").Range("B2") = "" Then
            MsgBox "該当する検索結果はありません。", vbExclamation, _
                        "バックナンバー検索"
        Else
            MsgBox "検索結果を表示しました。", vbInformation, _
                        "バックナンバー検索"
        End If
End Sub

Sub 期間設定()

    Dim Krowc As Long
    Dim i As Long, j As Long, p As Long
'期間設定がされていない場合はスキップ
        If fdatey = "" And fdatem = "" And fdated = "" Then Exit Sub
'対象期間外にチェックマークする
        For j = 2 To Krow
            Y = Left(Range("B" & j), 4)
            M = Mid(Range("B" & j), 5, 2)
            D = Mid(Range("B" & j), 7, 2)
            Worksheets("検索結果").Activate
    '部品化プロシージャーを呼び出し
            Call Module2.Check期間
            If Check = "NO" Then Range("A" & j) = "●"
        Next j
'対象期間外データを削除
        Call Module2.●削除
        With Worksheets("検索結果")
            .Range("A1").CurrentRegion.Sort key1:=.Range("B2"), _
                                Header:=xlYes
        End With
'対象内データを整理・体裁を整える
        Krowc = Range("B1").CurrentRegion.Rows.Count
        p = 1
        For i = 2 To Krowc
            Range("A" & i) = p
            p = p + 1
        Next i
        Call Module1.シート体裁
End Sub

Sub Check期間()
    Dim flga, flgb, flgc As Boolean
'変数の初期化
        flga = False
        flgb = False
        flgc = False
        Check = "YES"
        flga = (Y >= fdatey And Y <= tdatey)
        flgb = (M >= fdatem And M <= tdatem)
        flgc = (D >= fdated And D <= tdated)
'検索期間設定が空欄の時の対処
        If fdatey = "" Then flga = True
        If fdatem = "" Then flgb = True
        If fdated = "" Then flgc = True
'チェックマークの判定
        If (flga And flgb And flgc) = False Then
            Check = "NO"
        End If
End Sub

Sub ●削除()
    Dim Krow As Long
    Dim Krowb As Long
    Dim n As Long
        Krow = Range("B1").CurrentRegion.Rows.Count
        Range("A2:L" & Krow).RemoveDuplicates (Array(1))
        Krowb = Range("B1").CurrentRegion.Rows.Count
        For n = 2 To Krowb
            If Range("A" & n) = "●" Then
                Rows(n).Delete
            End If
        Next n
End Sub

Sub 検索結果クリア()
    Dim mb As Workbook
        Set mb = ThisWorkbook
        With mb.Worksheets("検索結果")
            .Select
            .Cells.Clear
            .Cells.UseStandardHeight = True
            .Cells.UseStandardWidth = True
        End With
End Sub