大量資料比對計算及排名

oak0723-1

各位先進好
我有一個資料如附件(因上傳檔案大小限制,故刪除部份工作表及儲存格)
1.(如圖01)在工作表"比對"的I3~IN3儲存格輸入資料
2..(如圖02)工作表"01"的I3~IN3儲存格資料=工作表"輸入"I3~IN3儲存格資料
3..(如圖02)工作表"01"I3:IN1048528的每一列儲存格資料都與I3~IN3儲存格資料比對,相同=1,不相同=0.空白=不進行比對,將比對結果逐列顯示於IT5:RY1048528儲存格
4..(如圖02)與工作表"01"相同的工作表有10個,除I3:IN1048528的儲存格內資料不一樣(列數欄數都不一樣),其他都一樣
5..(如圖01)將每個工作表("01"~"10")的IT5:RY1048528儲存格之每一列合計顯示於工作表"輸入"的I5~R1048528(若整列空白則不作計算)
6.(如圖01).將工作表"輸入"的I5~R1048528非空白逐列合計
7..(如圖01)將工作表"輸入"的I5~R1048528非空白逐列排名(例如S5=SUMPRODUCT(($S$5:$S$14>=S5)*(1/COUNTIF(S$5:S$14,S$5:S$14))))

samwang

回復 1# oak0723-1

圖1與圖2都是一樣

oak0723-1

回復 2# samwang


  抱歉抱歉
忘了檢查

samwang

回復 3# oak0723-1 [/b


你的圖2與附檔有點不一樣，且附檔的公式也跑掉了，
對不起很認真的在看了，但還是看不需求， 可以另外描敘一下，感謝

oak0723-1

回復 4# samwang


    抱歉抱歉
一錯再錯

更新資料

(1).(如圖001)在工作表"比對"的I3~IN3儲存格輸入資料
(2).(如圖002)工作表"01"的I3~IN3儲存格資料=工作表"輸入"I3~IN3儲存格資料
(3).(如圖002)工作表"01"I3:IN1048528的每一列儲存格資料都與I3~IN3儲存格資料比對,相同=1,不相同=0.空白=不進行比對,將比對結果逐列顯示於IT5:RY1048528儲存格
(4).(如圖002)與工作表"01"相同的工作表有10個,期內容格式相同,但I3:IN1048528的儲存格資料不同
(5).(如圖001)將每個工作表("01"~"10")的IT5:RY1048528儲存格之每一列合計顯示於工作表"輸入"的I5~R1048528
(6).(如圖001).將工作表"輸入"的I5~R1048528逐列合計
(7).(如圖001)將工作表"輸入"的I5~R1048528逐列排名(例如 T5=SUMPRODUCT(($S$5:$S$14>=S5)*(1/COUNTIF(S$5:S$14,S$5:S$14))))

下載 (225.74 KB)

2022-5-15 18:56

samwang

回復 5# oak0723-1

因為你的描述中第1點~7點有包含說明和需求，所以不確定如下是否為您的需求，如圖片紅框是有處理的結果，請測試看看，謝謝。

Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&
Set xD = CreateObject("Scripting.Dictionary")
Ar_in = Sheets("輸入").Range("i3:in3")
For sh = 2 To Sheets.Count
    With Sheets(sh)
        .Range("i3").Resize(1, UBound(Ar_in, 2)) = Ar_in
        R = .[b65536].End(3).Row: If R < 2 Then GoTo 95
        Arr1 = .Range(.[b5], .[b65536].End(3)): Arr = .Range("i3:in" & UBound(Arr1) + 4)
        ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2))       'IT3:RY
        ReDim Preserve Crr(1 To UBound(Arr) - 1, 1 To sh - 1)  '輸入的統計
        Crr(1, sh - 1) = .Name
        For x = 1 To UBound(Arr1)
            If Arr1(x, 1) = "" Then GoTo 95
            For i = 3 To UBound(Arr)
                For j = 1 To UBound(Arr, 2)
                    T = Arr(i, j): T1 = Arr(1, j)
                    If T1 = "" Then GoTo 90
                    If T1 = T Then
                        Brr(i - 2, j) = 1: n = n + 1
                    Else
                        Brr(i - 2, j) = 0
                    End If
90:             Next j
            Crr(i - 1, sh - 1) = n: n = 0
            Next i
95:     Next x
        .[it5].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    End With
Next
n = 0
With Sheets(1)
    .[i4:r4].NumberFormatLocal = "@"
    .[i4].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
    With [s5].Resize(UBound(Crr) - 1)
            .Formula = "=Sum(i5:r5)": .Value = .Value
    End With
    With Range([s5], [s4].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
    .[t5].Resize(UBound(Arr)) = Arr
End With
End Sub

oak0723-1

回復 6# samwang

先進你好
我執行後卡住如圖
我這個檔的概念就是想計算1組數字跟工作表01-10的每1列數據比較
計算每列相同數據的數量有多少

samwang

回復 7# oak0723-1

已更新如下，請再測試看看，謝謝
另外"輸入"工作表要放在第1個

Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&, sh%, MaxR&
Set xD = CreateObject("Scripting.Dictionary")
Ar_in = Sheets("輸入").Range("i3:in3")
For sh = 2 To Sheets.Count
    With Sheets(sh)
        .Range("i3").Resize(1, UBound(Ar_in, 2)) = Ar_in
        R = .[b65536].End(3).Row: If R < 2 Then GoTo 95
        Arr1 = .Range(.[b5], .[b65536].End(3)): Arr = .Range("i3:in" & UBound(Arr1) + 4)
        ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2)) 'IT3:RY
        ReDim Preserve Crr(1 To 100000, 1 To sh - 1)     '輸入的統計
        If MaxR < UBound(Arr) Then MaxR = UBound(Arr)
        Crr(1, sh - 1) = .Name
        For x = 1 To UBound(Arr1)
            If Arr1(x, 1) = "" Then GoTo 95
            For i = 3 To UBound(Arr)
                For j = 1 To UBound(Arr, 2)
                    T = Arr(i, j): T1 = Arr(1, j)
                    If T1 = "" Then GoTo 90
                    If T1 = T Then
                        Brr(i - 2, j) = 1: n = n + 1
                    Else
                        Brr(i - 2, j) = 0
                    End If
90:             Next j
            Crr(i - 1, sh - 1) = n: n = 0
            Next i
95:     Next x
        .[it5].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
    End With
Next
n = 0
With Sheets(1)
    .[i4:r4].NumberFormatLocal = "@"
    .[i4].Resize(MaxR, UBound(Crr, 2)) = Crr
    With .[s5].Resize(MaxR - 2)
            .Formula = "=Sum(i5:r5)": .Value = .Value
    End With
    With Range([s5], [s4].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
    .[t5].Resize(UBound(Arr)) = Arr
End With
End Sub

oak0723-1

回復 8# samwang


    我將工作表09的!5~IN1048528區域資料全部刪除執行程式後再輸入A1資料
結果就卡住了(如圖)

samwang

回復  samwang


    我將工作表09的!5~IN1048528區域資料全部刪除執行程式後再輸入A1資料
結果就卡住 ...
oak0723-1 發表於 2022-5-16 19:49

已更新如附件，請測試看看，謝謝