大量資料整理

oak0723-1

各位好
如附件及圖1說明
工作表"比對" I3~IN3儲存格及I3~IN3儲存格填入上限數據及下限數據
比對工作表"資料庫"中各列數據是否位於上下限數據中
若在上下限數據中(含上下限)顯示1
若數據大於上限值或小於下限值則顯示0
若上下限數據其中1個為空白,就不進行比對
並將各列結果合計

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與邏輯值運算,學習方案如下,請各位前輩指教

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

oak0723-1

回復 5# 准提部林


    感恩謝謝

oak0723-1

回復 10# samwang


    謝謝你
這樣真的很快

samwang

回復  samwang


若想針對h攔內數值做一個排名
公式如  =IF(H6="",0,SUMPRODUCT(($H$6H$500000>=H6 ...
oak0723-1 發表於 2022-6-5 23:21

新增紅字如下，請測試看看，謝謝
Set xD = CreateObject("Scripting.Dictionary")
...
...
...
     .Range("h6").Resize(UBound(Crr)) = Crr
    .Range("i6").Resize(UBound(Brr), UBound(Brr, 2)) = Brr

'排名
    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

回復 2# samwang


若想針對h攔內數值做一個排名
公式如  =IF(H6="",0,SUMPRODUCT(($H$6:$H$500000>=H6)*(1/COUNTIF(H$6:H$500000,H$6:H$500000))))
應該如何?

oak0723-1

回復 4# singo1232001


    感恩
謝謝

oak0723-1

回復 3# lpk187


    感恩
謝謝

oak0723-1

回復 2# samwang [/b

感恩
謝謝

准提部林

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