oak0723-1

回復 10# samwang


    先進你好
我將工作表01的I5:I1005填入資料1萬列資料,執行沒多久就顯示"沒回應",我想應該是當了
後來我一直刪減工作表01的I5:I1005資料列數測試執行,發現剩2千列耗約15分鍾完成
不知是否執行速度效能是否有辦法予以提升?

samwang

回復  samwang


    先進你好
我將工作表01的I5:I1005填入資料1萬列資料,執行沒多久就顯示"沒回應",我 ...
oak0723-1 發表於 2022-5-17 09:12

已更新，4萬多筆約12秒，檔案太大66M不上傳，請自行建資料後再測試看看，謝謝
另外，用你的#11附件檔案去執行會跑很久(當掉)，重建資料數據，建議數值轉為值不要框線然後再執行程式(如圖片)

Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&, sh%, MaxR&
Set xD = CreateObject("Scripting.Dictionary")
Tm = Timer
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("b4:b" & R): Arr = .Range("i3:in" & R)
        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 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
95:    Next i
        .[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
MsgBox Timer - Tm
End Sub

下載 (141.03 KB)

2022-5-17 11:02

oak0723-1

回復 12# samwang


    謝謝
完全符合我的希望
謝謝你

singo1232001

回復 13# oak0723-1

excel 2019
2017年的電腦  r7-1700x  記憶體3000 cpu99%

10頁 共40萬筆 36秒

檔案大小 336MB
https://drive.google.com/file/d/1dRNroDrAKxhnoKg9qp9IJhO7pemwGh6j/view?usp=sharing

多的部分都刪了  IN 右邊的都刪了  太龐大

要大量資料 就要盡量不用任何顏色格式

oak0723-1

回復 14# singo1232001


    收到
感恩
:)

oak0723-1

回復 14# singo1232001


  抱歉
我剛測試發現幾個問題

就是當在工作表"輸入" L3儲存格輸入4001(如圖01)
而工作表01-10的儲存格L3卻沒有跟著改變(圖02)
所以比對結果也有問題(如圖03)
工作表01-10沒有比對結結果(如圖04)

singo1232001

回復 16# oak0723-1

改好了 會在程序裡更新
不過表上不變更  若想要用=號更新01~10[I3~IN3] 檔案會變慢  
目前01~10[I3:IN3]甚至刪掉也可以


    Sub test()
TT = Timer
Set sh0 = Sheets("輸入")
ReDim ar(1 To Sheets.Count - 1): w = 1
ReDim ar0(1 To Sheets.Count - 1)
ReDim ar1(1 To Sheets.Count - 1)
sh0.[i5:T1048576].ClearContents
For Each Z In Sheets
If Z.Name <> "輸入" Then
ar(w) = Z.Range("I5:IN" & Z.Cells(Rows.Count, 2).End(3).Row)
  ar0(w) = sh0.[I3:IN3]
   ReDim ir(1 To UBound(ar(w)), 0)
   ar1(w) = ir
    If MaxR < UBound(ar(w)) Then MaxR = UBound(ar(w))
     w = w + 1
End If
Next

ReDim ar2(1 To MaxR, 0)
For i = 1 To MaxR: ar2(i, 0) = 0: Next

For i = 1 To UBound(ar)
    For j = 1 To UBound(ar(i))
        For k = 1 To 240
        If ar(i)(j, k) = ar0(i)(1, k) Then
        ar1(i)(j, 0) = ar1(i)(j, 0) + 1
        ar2(j, 0) = ar2(j, 0) + 1
        End If
        Next
    Next
Next

For i = 1 To UBound(ar)
sh0.Cells(5, i + 8).Resize(UBound(ar1(i)), 1) = ar1(i)
Next
sh0.[s5].Resize(UBound(ar2), 1) = ar2

Set d = CreateObject("scripting.dictionary"): d.RemoveAll
For i = 1 To UBound(ar2): d(ar2(i, 0)) = "": Next: d0 = d.keys()
  For i = 0 To d.Count - 1
    For j = i + 1 To d.Count - 1
      If d0(i) < d0(j) Then tp = d0(i): d0(i) = d0(j): d0(j) = tp
    Next j:  Next i
ReDim d1(0 To d0(0))
For i = 0 To UBound(d0): d1(d0(i)) = i + 1: Next
  For i = 1 To UBound(ar2): ar2(i, 0) = d1(ar2(i, 0)): Next
   sh0.[T5].Resize(UBound(ar2), 1) = ar2
   
sh0.[A1] = Format(Timer - TT, "0.0")
End Sub

oak0723-1

回復 17# singo1232001


    抱歉,漏了1個問題
1.輸入欄位若是空白,就不比對,所得的值就是0(如圖)
2.輸入欄位若是0,比對蘭欄位若是空白,所得的值也是0(如圖)

oak0723-1

回復 12# samwang

抱歉,漏了1個問題
1.輸入欄位若是空白,就不比對,所得的值就是0(如圖)
2.輸入欄位若是0,比對蘭欄位若是空白,所得的值也是0(如圖)

singo1232001

回復 19# oak0723-1

測試看看

    Sub test()
TT = Timer
Set sh0 = Sheets("輸入")
ReDim ar(1 To Sheets.Count - 1): w = 1
ReDim ar0(1 To Sheets.Count - 1)
ReDim ar1(1 To Sheets.Count - 1)
sh0.[i5:T1048576].ClearContents
For Each Z In Sheets
If Z.Name <> "輸入" Then
ar(w) = Z.Range("I5:IN" & Z.Cells(Rows.Count, 2).End(3).Row)
  ar0(w) = sh0.[I3:IN3]
   ReDim ir(1 To UBound(ar(w)), 0)
   ar1(w) = ir
    If MaxR < UBound(ar(w)) Then MaxR = UBound(ar(w))
     w = w + 1
End If
Next

ReDim ar2(1 To MaxR, 0)
For i = 1 To MaxR: ar2(i, 0) = 0: Next

For i = 1 To UBound(ar)
    For j = 1 To UBound(ar(i))
        For k = 1 To 240
        If ar0(i)(1, k) <> "" Then
            If ar(i)(j, k) = ar0(i)(1, k) Then
            ar1(i)(j, 0) = ar1(i)(j, 0) + 1
            ar2(j, 0) = ar2(j, 0) + 1
            End If
        End If
        Next
    Next
Next

For i = 1 To UBound(ar)
sh0.Cells(5, i + 8).Resize(UBound(ar1(i)), 1) = ar1(i)
Next
sh0.[s5].Resize(UBound(ar2), 1) = ar2

Set d = CreateObject("scripting.dictionary"): d.RemoveAll
For i = 1 To UBound(ar2): d(ar2(i, 0)) = "": Next: d0 = d.keys()
  For i = 0 To d.Count - 1
    For j = i + 1 To d.Count - 1
      If d0(i) < d0(j) Then tp = d0(i): d0(i) = d0(j): d0(j) = tp
    Next j:  Next i
ReDim d1(0 To d0(0))
For i = 0 To UBound(d0): d1(d0(i)) = i + 1: Next
  For i = 1 To UBound(ar2): ar2(i, 0) = d1(ar2(i, 0)): Next
   sh0.[T5].Resize(UBound(ar2), 1) = ar2
   
sh0.[A1] = Format(Timer - TT, "0.0")
End Sub