収穫記録に対応する播種記録を検索する - DrunkBacchus

播種記録を検索する関数

Function FindSowData(StartDate As Date, _
                     Enddate As Date, _
                     Optional House As Variant = "", _
                     Optional Product As String = "", _
                     Optional Seed As String = "") As Variant
   '播種記録を検索する関数
   '引数
   '   検索開始期間
   '   検索終了期間
   '   ハウス          Option
   '   品目            Option
   '   品種            Option
   '
   '戻り値
   '   播種番号を配列で返す
   '   対応データがない場合Nothing
 
   Dim SrcBook As Workbook
   Dim SrcSheet As Worksheet
   Dim SrcData As Range
   Dim TempSheet As Worksheet
   Dim CriteriaA() As Variant
   Dim CriteriaR As Range
   Dim DistRange As Range
   Dim ResultArray As Variant
   
   
'    Application.ScreenUpdating = False
   On Error GoTo err1
   '元データ範囲
   Set SrcData = Workbooks("播種記録2006.xls").Worksheets("播種記録").Range("$A$6:$N$239")
   '抽出用シートを用意
'    Set TempSheet = Worksheets.Add
   Set TempSheet = Worksheets("Temp")

   'Criteria範囲を設定
   Set CriteriaR = TempSheet.Range("A1:E2")
   '抽出先範囲を設定
   Set DistRange = TempSheet.Range("A5")
   DistRange.Value = "番号"
   ReDim CriteriaA(1 To 2, 1 To 5)
   CriteriaA(1, 1) = "播種日" '開始日
   CriteriaA(1, 2) = "播種日" '終了日
   CriteriaA(1, 3) = "ハウス" '
   CriteriaA(1, 4) = "品目" '
   CriteriaA(1, 5) = "品種" '
   
   CriteriaA(2, 1) = ">=" & StartDate  '開始日
   CriteriaA(2, 2) = "<=" & Enddate    '終了日
   CriteriaA(2, 3) = House      '
   CriteriaA(2, 4) = Product    '
   CriteriaA(2, 5) = Seed       '
   CriteriaR = CriteriaA

   'Criteriaによる抽出
   On Error GoTo err2
   SrcData.AdvancedFilter Action:=xlFilterCopy, _
       CriteriaRange:=CriteriaR, _
       CopyToRange:=DistRange, _
       Unique:=False
   
   Set DistRange = DistRange.CurrentRegion
   Set DistRange = DistRange.Offset(1, 0).Resize(DistRange.Rows.Count - 1, 1)
   Set ResultArray = DistRange
   
   '結果の行数をカウントする
   If ResultArray.Rows.Count > 1 Then
       FindSowData = ResultArray
   Else
       FindSowData = False
   End If

   GoTo WindUp
err1:   '設定時のエラー
   MsgBox "設定時のエラー"
   FindSowData = False
   GoTo WindUp

err2:   'フィルタ時のエラー
   MsgBox "フィルタ時のエラー"
   FindSowData = False
   GoTo WindUp

WindUp: '後始末－終了
myTimer3 = Timer
   CriteriaR.Clear
   DistRange.Clear
   On Error Resume Next
'    Application.DisplayAlerts = False
'    TempSheet.Delete
'    Application.DisplayAlerts = True
   Set SrcBook = Nothing
   Set SrcSheet = Nothing
   Set SrcData = Nothing
   Set TempSheet = Nothing
   Set CriteriaR = Nothing
   Set DistRange = Nothing
   Set ResultArray = Nothing
End Function