Option Explicit
Sub test()
Dim arr, i, j, m, mark
arr = Sheets("sheet1").[a1].CurrentRegion.Offset(1)
With Sheets("sheet2")
mark = .[b2].CurrentRegion.Offset(1)
If Len(mark(1, 1)) = 0 Then mark(1, 1) = #1/1/2000#
If Len(mark(1, 12)) = 0 Then mark(1, 12) = Date
For i = 1 To UBound(arr, 1) - 1
If CDate(arr(i, 11)) >= mark(1, 1) And CDate(arr(i, 11)) <= mark(1, 12) Then
For j = 2 To 11
If Len(mark(1, j)) > 0 And InStr(arr(i, j - 1), mark(1, j)) = 0 Then Exit For
Next
If j = 12 Then
m = m + 1
For j = 1 To UBound(arr, 2)
arr(m, j) = arr(i, j)
Next
End If
End If
Next
With .[c6]
.Resize(UBound(arr, 1) * 2, UBound(arr, 2)).ClearContents
If m > 0 Then .Resize(m, UBound(arr, 2)) = arr
End With
End With
End Sub |