請測試一下,謝謝 Sub test() Dim Arr, a, xD, Brr(), T$, i& Set xD = CreateObject("Scripting.Dictionary") Arr = Range("u3").CurrentRegion For i = 1 To UBound(Arr) T = Arr(i, 1): xD(T) = Arr(i, 2) Next Arr = Range([m2], [m65536].End(3)) ReDim Brr(1 To UBound(Arr), 1 To 1) For Each ky In xD.keys a = Split(ky, "到") For i = 1 To UBound(Arr) If CDate(Arr(i, 1)) > a(0) And CDate(Arr(i, 1)) < a(1) Then Brr(i, 1) = xD(ky) End If Next Next Range("s2").Resize(UBound(Brr), 1) = Brr End Sub
|