軒云熊

回復 10# qaqa3296
別這麼說  我也是新手 我們互相學習 互相幫助   我想無法解決的問題  在提出來大大們也會有答案

准提部林

Sub TEST_A1()
Dim Arr, T$(2), D(2), i&, j%, N&
[成果!A2:D2000].ClearContents
D(0) = [Form!E2]
If IsDate(D(0)) = False Then Exit Sub
Arr = Range([目標!F1], [目標!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    If Arr(i, 1) = "" Then GoTo i01 '[品號]空白, 略過
    D(1) = Arr(i, 5) '[生效日期]
    D(2) = Arr(i, 6) '[失效日期]
    If IsDate(D(1)) Then If CDate(D(1)) > D(0) Then GoTo i01 '[生效日期]有日期, 且>指定日, 略過
    If IsDate(D(2)) Then If CDate(D(2)) <= D(0) Then GoTo i01 '[失效日期]有日期, 且<=指定日, 略過
    N = N + 1
    For j = 1 To 4: Arr(N + 1, j) = Arr(i, j): Next j
i01: Next i
If N > 0 Then [成果!A1].Resize(N + 1, 4) = Arr
End Sub

兩個日期相同, 必包含在那兩個if條件中, 不必另行判斷:
例如:指定日2020/9/8
2020/9/7  2020/9/7 失效日期<=指定日
2020/9/12  2020/9/12  生效日期>指定日


'================================

jcchiang

回復 7# qaqa3296

試試看
Sub ex()
Dim c As Range
Dim a As Object
Dim 日期$
日期 = Sheets("Form").[E2]
Sheets("成果").Range([a2], [a2].End(4).Offset(, 5)).ClearContents
Set c = Nothing
With Sheets("目標")
For Each a In .Range(.[a2], .[a65535].End(3))
   If (a.Offset(, 5) = "" Or a.Offset(, 5) > 日期) And (a.Offset(, 4) = "" Or a.Offset(, 4) <= 日期) Then
      If c Is Nothing Then
         Set c = a.Resize(, 6)
      Else
         Set c = Union(c, a.Resize(, 6))
      End If
   End If
Next
End With
c.Copy Sheets("成果").[a2]
Set c = Nothing
End Sub

qaqa3296

回復 13# jcchiang

感謝准提部林、jcchiang

提供其他寫法供大家學習

程式效果都正確

想問一下jcchiang大大

你的程式我看不出來有宣告或其他日期函數?

那為何可以正確判斷日期呢?

還是藏在哪我沒有注意到?

軒云熊

看起來好像是全都依據物件或範圍本身的格式

軒云熊

准大大 還有 jcchiang大大 的 思考邏輯更整密   
可以覆蓋使用原來的陣列空間 還有略過的方式做判斷
    學習中

jcchiang

回復 14# qaqa3296


    我只是依據你的檔案內容去寫,並沒有去判斷可能的日期格式問題

准提部林

如果不判斷日期格式:
Sub TEST_A2()
Dim Arr, D, i&, j%, N&
[成果!A2:D2000].ClearContents
D = [Form!E2]: If D = "" Then Exit Sub
Arr = Range([目標!F1], [目標!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    If Arr(i, 5) <> "" And Arr(i, 5) > D Then GoTo i01
    If Arr(i, 6) <> "" And Arr(i, 6) <= D Then GoTo i01
    N = N + 1
    For j = 1 To 4: Arr(N + 1, j) = Arr(i, j): Next j
i01: Next i
If N > 0 Then [成果!A1].Resize(N + 1, 4) = Arr
End Sub

准提部林

如果資料不多, 直接用range即可
Sub TEST_A3()
Dim xR As Range, D
[成果!A2:D2000].ClearContents
D = [Form!E2]: If D = "" Then Exit Sub
Application.ScreenUpdating = False
For Each xR In Range([目標!A2], [目標!A65536].End(xlUp))
    If (xR(1, 5) > D) + (xR(1, 6) <> "") * (xR(1, 6) <= D) Then GoTo 101
    xR.Resize(1, 4).Copy [成果!A65536].End(xlUp)(2)
101: Next
End Sub