Excel VBAにおける複数条件での検索方法

以下のように、Excelシートがあって
このExcelシートで以下の条件で検索、その結果を返すVBAを作りたいのですが、悩んでいます。
　　検索条件　果物：りんご
　　　　　　 産地：青森　
　　　　　　　複数ある時は、購入日が一番古いものを選ぶ。
　　　　　　　更に複数ある時は、値段の安いものを選ぶ。
　　　⇒行番号を返す
　　これで、1つの行が選択できたら、そのF列に「在庫なし」を挿入する。

　　　A列　　　　B列　　C列　　D列　　E列　　F列
1行　購入日　　　果物　　産地　　数量　値段　　在庫
2行　2017/4/10　りんご　　青森　　2　　110
3行　2017/4/10　みかん　　愛媛　　3　　350
4行　2017/4/10　りんご　　青森　　1　　100
5行　2017/4/10　りんご　　長野　　2　　120
6行　2017/4/12　みかん　　静岡　　3　　350
7行　2017/4/13　みかん　　愛媛　　2　　240
8行　2017/4/14　りんご　　長野　　2　　120
9行　2017/4/15　りんご　　青森　　1　　100

結果としては、上から4行目のリンゴのF列に「在庫なし」が
入るようにしたいです。
すみません、いろろと調べてはいるのですが、ちょっとわからず、こちらに投稿しました。どなたか、わかる方教えていただければ幸いです。
よろしくお願いします。

No.2 回答者： WindFaller 回答日時： 2017/04/18 19:09

こんばんは。

以下は、手作業ですることを、マクロに写しただけのものです。
コードは細かいですが、仕組みは分かっていただけると思います。

H列　　　I列　　　J列　　　　この3つの列の2行目に条件を書きます。
果物　　産地　　購入日
りんご　青森　　2017/4/10

J列は、計算で出されています。自動的に数式が入ります。
J2: =DMIN(A1:F9,J1,H1:I2)
同列の時は、ふたつに「在庫なし」が入ります。


'//
Sub FindStocks()
　Dim LastCell As Range
　Dim Rng As Range
　Dim VRng5 As Range　'値段
　Dim VRng1 As Range '未使用
　Dim vMin As Long
　Dim CritRange As Range
　Dim c As Range
　With ActiveSheet
　　Set CritRange = Range("H1:J2")　'条件を入れる範囲
　　If .FilterMode Then
　　　.Range("A1").AutoFilter
　　　.Range("A1").AutoFilter
　　End If
　　'必ずフィルド名と合わせてください。
　　CritRange.Resize(1, 3).Value = Array("果物", "産地", "購入日")
　　For Each c In CritRange.Resize(1, 2)
　　　If c.Offset(1).Value = "" Then
　　　　MsgBox c.Value & "の値を入れてください", vbExclamation
　　　　Exit Sub
　　　End If
　　Next
　　Set LastCell = .Cells(Rows.Count, 1).End(xlUp).Offset(, 5)
　　Set Rng = .Range("A1", LastCell)
　　CritRange.Cells(2, 3).FormulaLocal = _
　　"=DMIN(" & Rng.Address & "," & CritRange.Cells(1, 3).Address & "," & CritRange.Resize(2, 2).Address & ")"

　　Rng.AdvancedFilter _
　　　　Action:=xlFilterInPlace, _
　　　　CriteriaRange:=CritRange, Unique:=False
　　On Error Resume Next
　　'在庫なしを消す
　　Rng.Columns(6).Offset(1).SpecialCells(xlCellTypeConstants).ClearContents
　　On Error GoTo 0
　　Set VRng5 = Rng.Columns(5).SpecialCells(xlCellTypeVisible)
　　If Application.Subtotal(2, VRng5) = 1 Then
　　　VRng5.Cells(VRng5.Cells.Count, 2).Value = "在庫なし"
　　Else
　　　vMin = Application.Subtotal(5, VRng5)
　　　For Each c In VRng5.Cells
　　　　If vMin = c.Value Then
　　　　　c.Offset(, 1).Value = "在庫なし"
　　　　End If
　　　Next
　　End If
　　.Range("A1").AutoFilter
　　.Range("A1").AutoFilter
　　.Range("A1").Select
　End With
End Sub

No.1 回答者： t_fumiaki 回答日時： 2017/04/18 14:19

Sub WK()

　　Dim HI As Date
　　Dim Sh As Worksheet
　　Set Sh = ActiveSheet
　　
　　END1 = Sh.Range("A65536").End(xlUp).Row
　　HI = "9999/12/31"
　　KAKAKU = 99999999
　　行 = 0
　　
　　For CNT = 2 To END1
　　
　　If Sh.Range("B" & CNT).Value = "りんご" And Sh.Range("C" & CNT).Value = "青森" Then
　　　If Sh.Range("A" & CNT).Value < HI Then
　　　　HI = Sh.Range("A" & CNT).Value
　　　　KAKAKU = Sh.Range("E" & CNT).Value
　　　　行 = CNT
　　　ElseIf Sh.Range("A" & CNT).Value = HI Then
　　　
　　　 If Sh.Range("E" & CNT).Value < KAKAKU Then
　　　　KAKAKU = Sh.Range("E" & CNT).Value
　　　　行 = CNT
　　　 End If
　　　End If
　　End If
　　　　　
　　Next CNT
　　
　　If 行 > 0 Then
　　　　Sh.Range("F" & 行).Value = "在庫なし"
　　End If
End Sub