Sub test()
Dim Arr, Drr, Brr(), Crr(), T, XMax, XMin, R%, C%, i&
Tm = Timer
With Sheets("資料庫")
R = .[b6].End(4).Row
C = .Cells(5, Columns.Count).End(1).Column
Arr = .Range(.[b6], .Cells(R, 2))
Drr = .Range(.[i6], .Cells(R, C))
End With
With Sheets("比對")
.[b6].Resize(UBound(Arr)) = Arr
ReDim Brr(1 To UBound(Arr), 1 To UBound(Drr, 2))
ReDim Crr(1 To UBound(Arr), 1 To 1)
C = .Cells(3, Columns.Count).End(1).Column
Arr = .Range(.[i3], .Cells(4, C))
For i = 1 To UBound(Drr)
For j = 1 To UBound(Arr, 2)
T = Drr(i, j): XMin = Arr(1, j): XMax = Arr(2, j)
If XMin = "" Or XMax = "" Then Brr(i, j) = "": GoTo 99
If T < XMin Or T > XMax Then
Brr(i, j) = 0
ElseIf T >= XMin Or T <= XMax Then
Brr(i, j) = 1: Crr(i, 1) = Crr(i, 1) + 1
End If
99: Next j
Next i
.Range("h6").Resize(UBound(Crr)) = Crr
.Range("i6").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End With
MsgBox Timer - Tm
End Sub作者: lpk187 時間: 2022-6-2 12:14
Sub 比對()
Dim Brr() As Variant
Dim Arr() As Variant
Dim Crr()
Tm = Timer
Brr = Worksheets("比對").Range("I3:IN4").Value
Arr = Worksheets("資料庫").[I6:IN6].Value
ReDim Crr(1 To UBound(Arr, 2), 1 To 1)
n = 1
For Each s In Arr
If s >= Brr(1, n) And s <= Brr(2, n) Then
Crr(n, 1) = 1
ElseIf Brr(1, n) = "" Or Brr(2, n) = "" Then
Crr(n, 1) = ""
Else
Crr(n, 1) = 0
End If
n = n + 1
Next
MsgBox Timer - Tm
End Sub作者: singo1232001 時間: 2022-6-3 18:22
Sub 比對db()
T = Timer
Set s = Sheets("比對")
rw = s.Cells(Rows.Count, "i").End(3).Row
If rw <= 5 Then rw = 5
s.Range("h5:in" & rw).ClearContents
ar = s.[I3:IN5]
br = Sheets("資料庫").Range("H5:IN" & Sheets("資料庫").Cells(Rows.Count, "i").End(3).Row)
For i = 1 To UBound(br): br(i, 1) = 0: Next
For i = 1 To UBound(br, 2): br(1, i) = 0: Next
For i = 1 To UBound(ar, 2)
k = i + 1
If ar(1, i) <> "" Or ar(2, i) <> "" Then
For j = 2 To UBound(br)
If ar(1, i) <= br(j, k) Then
If br(j, k) <= ar(2, i) Then
br(1, k) = br(1, k) + 1
br(j, 1) = br(j, 1) + 1
br(j, k) = 1
Else
br(j, k) = 0
End If
Else
br(j, k) = 0
End If
Next
Else
For j = 2 To UBound(br): br(j, k) = "": Next
End If
Next
br(1, 1) = "合計"
s.[h5].Resize(UBound(br), UBound(ar, 2) + 1) = br
MsgBox Format(Timer - T, "0.0") & "秒"
End Sub
優化過 怕你量過大作者: 准提部林 時間: 2022-6-3 22:12
Sub TEST_A1()
Dim Arr, Brr, Crr, R&, C%, V(3)
With Sheets("資料庫")
Arr = Range(.Cells(Rows.Count, 2).End(3), .Cells(5, Columns.Count).End(1)(2))
R = UBound(Arr): C = UBound(Arr, 2)
End With
Brr = Sheets("比對").[b3].Resize(2, C)
ReDim Crr(1 To R, 1 To C)
For j = 8 To C
V(1) = Brr(1, j): V(2) = Brr(2, j)
If V(1) = "" Or V(2) = "" Then GoTo j01
For i = 1 To R
If j = 8 Then Crr(i, 1) = Arr(i, 1)
V(3) = Arr(i, j): If V(3) = "" Then GoTo i01
V(0) = (V(3) >= V(1)) * (V(3) <= V(2))
Crr(i, j) = V(0)
Crr(i, 7) = Crr(i, 7) + V(0)
i01: Next i
j01: Next j
Sheets("比對").[b6].Resize(R, C) = Crr
End Sub作者: oak0723-1 時間: 2022-6-4 00:13
'排名
With .Range(.[h6], .[h6].End(4))
Arr = .Value
.Sort Key1:=.Item(1), Order1:=2, Header:=2
Brr = .Value: .Value = Arr
End With
For i = 1 To UBound(Brr)
T = Brr(i, 1): If Not xD.Exists(T) Then n = n + 1: xD(T) = n
Next
For i = 1 To UBound(Arr): Arr(i, 1) = xD(Arr(i, 1)): Next
.[g6].Resize(UBound(Arr)) = Arr
End With作者: oak0723-1 時間: 2022-6-6 22:37
Option Explicit
Sub TEST_1()
Dim Brr, Crr, Arr, v, i&, j%, R&, C%
Dim S1 As Worksheet, S2 As Worksheet
Set S1 = Sheets("資料庫"): Set S2 = Sheets("比對")
R = S1.Cells(Rows.Count, "B").End(xlUp).Row
C = S1.Cells(5, Columns.Count).End(xlToLeft).Column
Brr = Range(S1.Cells(R, "I"), S1.Cells(6, C))
Crr = Range(S2.[I3], S2.Cells(4, C))
ReDim Arr(1 To UBound(Brr), UBound(Brr, 2))
For j = 1 To UBound(Brr, 2)
If (Crr(1, j) <> "") * (Crr(2, j) <> "") = 0 Then GoTo j01
For i = 1 To UBound(Brr)
v = Brr(i, j)
If v = "" Then GoTo i01
Arr(i, j) = (v >= Crr(1, j)) * (v <= Crr(2, j))
Arr(i, 0) = Arr(i, 0) + Arr(i, j)
i01: Next
j01: Next
S2.[H6].Resize(UBound(Arr), UBound(Arr, 2) + 1) = Arr
S2.Range("B6:B" & R) = S1.Range("B6:B" & R).Value
Set S1 = Nothing: Set S2 = Nothing: Erase Brr, Crr, Arr
End Sub
