- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2023-9-21
|
12#
發表於 2022-5-17 11:02
| 只看該作者
本帖最後由 samwang 於 2022-5-17 11:15 編輯
回復 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
|
|
