返回列表 上一主題 發帖

大量資料比對計算及排名

大量資料比對計算及排名

各位先進好
我有一個資料如附件(因上傳檔案大小限制,故刪除部份工作表及儲存格)
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))))
圖01.jpg
圖02.jpg

(1110513)比對.rar (37.42 KB)

回復 1# oak0723-1

圖1與圖2都是一樣

TOP

回復 2# samwang


  抱歉抱歉
忘了檢查
圖02.jpg

TOP

回復 3# oak0723-1 [/b


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

TOP

回復 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))))
圖001.jpg
2022-5-15 18:56
圖002.jpg

(1110513)比對.zip (61.25 KB)

TOP

回復 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
1.JPG

TOP

回復 6# samwang

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

(1110516)比對test.part001.rar (1 MB)

(1110516)比對test.part002.rar (1 MB)

(1110516)比對test.part003.rar (1 MB)

(1110516)比對test.part004.rar (1 MB)

(1110516)比對test.part005.rar (1 MB)

(1110516)比對test.part006.rar (1 MB)

(1110516)比對test.part007.rar (1 MB)

(1110516)比對test.part008.rar (1 MB)

(1110516)比對test.part009.rar (1 MB)

(1110516)比對test.part010.rar (1 MB)

(1110516)比對test.part011.rar (1 MB)

(1110516)比對test.part012.rar (1 MB)

(1110516)比對test.part013.rar (202.04 KB)

TOP

回復 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
1.JPG

TOP

回復 8# samwang


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

(1110516-1)比對test.rar (218.55 KB)

TOP

回復  samwang


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


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

(1110516-1)比對test_0516.zip (199.4 KB)

TOP

        靜思自在 : 對父母要知恩,感恩、報恩。
返回列表 上一主題