[attach]32535[/attach]

[attach]32536[/attach]

javascript:;

U = True: K = 1
For i = 1 To UBound(Arr)
If U = True Then
For F = 1 To UBound(Arr, 2)
Brr(1, F) = Arr(1, F)
Next F
U = False
End If

javascript:;

javascript:;

javascript:;

7樓的那個檔可以看出我想要的邏輯。

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

2020/9/7  2020/9/7 失效日期<=指定日
2020/9/12  2020/9/12  生效日期>指定日

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

Sub ex()
Dim c As Range
Dim a As Object
Dim 日期\$

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

學習中

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

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

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

 歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)