エクセルＶＢＡを使ったバックナンバー検索！店長の強力業務ツール。

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

Sub 雑誌名検索()
    Dim Tc As Range
    Dim Tcs As Range
    Dim myRange As Range
    Dim Frow As Long
    Dim i As Long, n As Long

    Worksheets("検索結果").Select
    検索結果クリア
    
    Worksheets("データまとめ").Range("A1", "L1").Copy _
                    Destination:=Worksheets("検索結果").Range("A1")

     Worksheets("データまとめ").Select
    Drow = Worksheets("データまとめ").Range("B1").CurrentRegion.Rows.Count
    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 & "」はありませんでした"
            Exit Sub
            検索結果クリア
        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
    期間設定
End Sub

Sub 期間設定()
    
 Dim Y As Long
 Dim M As Long
 Dim D As Long
 Dim Krowc As Long
 Dim i As Long, j As Long, p As Long
    
 If fdatey = "" And tdatey = "" Then
    GoTo L01
 End If
    
    For j = 2 To Krow
        Y = Left(Range("B" & j), 4)
            If fdatey <> "" Then
                If Y < fdatey Then Range("A" & j) = "●" If Y > tdatey Then Range("A" & j) = "●"
            End If
        If Range("A" & j) <> "●" Then
            If fdatem = "" And tdatem = "" Then
            GoTo L02
            End If
            M = Mid(Range("B" & j), 5, 2)
                If fdatem <> "" Then
                    If M < fdatem Then Range("A" & j) = "●" If M > tdatem Then Range("A" & j) = "●"
                Else
                    fdatem = 0
                    If M > tdatem Then Range("A" & j) = "●"
                End If
        Else
        End If
        If Range("A" & j) <> "●" Then
            If fdated = "" And tdated = "" Then
            GoTo L02
            End If
            D = Mid(Range("B" & j), 7, 2)
            If fdated <> "" Then
                If D < fdated Then Range("A" & j) = "●" If D > tdated Then Range("A" & j) = "●"
            End If
        Else
        End If
L02:
    Next j
    
L01:
 Application.CutCopyMode = False

 ●削除

 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
    
 Range("A1").Select
 Module1.シート体裁
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 雑誌NO検索()

    Dim Tcb As Range
    Dim Tcsb As Range
    Dim myRangeb As Range
    Dim Frowb As Long
    Dim i As Long, n As Long

    Worksheets("検索結果").Select
    検索結果クリア
    
    Worksheets("データまとめ").Range("A1", "L1").Copy _
                    Destination:=Worksheets("検索結果").Range("A1")

     Worksheets("データまとめ").Select
    Drow = Worksheets("データまとめ").Range("B1").CurrentRegion.Rows.Count
    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 & "」はありませんでした"
            Exit Sub
            検索結果クリア
        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
    期間設定

End Sub

Sub 検索結果クリア()

    Worksheets("検索結果").Cells.Clear
    With Worksheets("検索結果")
        .Cells.UseStandardHeight = True
        .Cells.UseStandardWidth = True
    End With

End Sub