12
返回列表 上一主題 發帖

[發問] 誰能幫這幾乎重複動作的VBA瘦身 謝謝

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
1# 跳轉到 »
發表於 2015-8-28 12:23 | 顯示全部帖子
光〔複製．貼上〕就要耗費大半天時間，尤其文字或公式更耗時，
使用陣列直接運算取出結果再貼入，因判斷值只有０及１，貼入時還算快，
雖是最基本的〔陣列．array〕運用，但對初學者也頗有難度，恕無法解說，參考即可：
test01.rar (139.58 KB)
　
若資料太多，可能造成記憶體不足問題，試試看！
我只插花，此論壇各板主皆是專業高手，可請求其協助！
　
Sub 分析()
Dim Srr, Sht As Worksheet, Arr, Brr, Crr, X, Y, Z, R, TM
Dim i&, j&, k%, M, Mrr(1 To 2560, 1 To 2), S&, SU&

TM = Timer
R = [data!C65536].End(xlUp).Row
Arr = [Data!C1:D1].Resize(R)
X = [Data!I4]: If X < 2 Then X = 2
Y = [Data!J4]: If Y > R Then Y = R
Z = Y - X + 1: If Z <= 0 Then Exit Sub

ReDim Crr(X To Y, 1 To 256)
Application.ScreenUpdating = False
For i = 1 To 10
    Set Sht = Sheets("析" & i)
    Brr = Sht.Rows(1)
    For k = 1 To 256
        M = M + 1
        For j = X To Y
            If Brr(1, k) <= Arr(j, 1) And Brr(1, k) >= Arr(j, 2) Then S = 1
            Crr(j, k) = S: SU = SU + S: S = 0
        Next j
        Mrr(M, 1) = Brr(1, k):  Mrr(M, 2) = SU:   SU = 0
    Next k
    Sht.UsedRange.Offset(1, 0).ClearContents
    With Sht.[A2].Resize(Z, 256)
         Sht.Rows(2).Copy .Cells
         .Value = Crr
    End With
Next i

Sheets("結果").[A3:B3].Resize(M) = Mrr
MsgBox Timer - TM
End Sub

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
2#
發表於 2015-8-28 14:01 | 顯示全部帖子
程式只取得各股價參數的符合次數,並輸出至〔結果〕表的ＡＢ欄，
至於ＣＤ欄如何計算〔發生率〕，須自行去套公式！

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
3#
發表於 2015-8-29 18:58 | 顯示全部帖子
為何我只要開啟您的檔案 我未做任何動作便關上 它就會提示資料已更改 問我要不要存檔???
OFFSET,INDIRECT,NOW,TODAY....等等函數, 都會造成這個提示!

SUMPRODUCT計算上萬筆資料, 若PC等級不高, 大部份光開啟檔案就要等很久,
又, 若是為[常駐]公式, 統計來源表任一儲存格每一次變動, 即會跑出〔自動重算〕(俗稱:卡檔), 非常不方便,

使用VBA可以改善以上情況, 缺點是：數據變動後, 必須再執行程式, 無法隨時顯示動態結果!

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
4#
發表於 2015-8-29 20:48 | 顯示全部帖子
用上次VBA修改如下（只列出結果表Ｂ欄次數，其他不處理）：
TEST02.rar (134.34 KB)

Sub 分析()
Dim Arr, Brr, Cunt&, Crr%(), R&, X&, Y&, TM, j%, k&, SU%
TM = Timer
R = [data!C65536].End(xlUp).Row
Arr = [Data!C1:D1].Resize(R)

X = Val([Data!I6]): If X < 2 Then X = 2
Y = Val([Data!J6]): If Y > R Then Y = R
If Y <= X Then Exit Sub

Cunt = 2560
ReDim Crr(1 To Cunt, 0)
Brr = [結果!A3].Resize(Cunt)
For j = 1 To Cunt
　　For k = X To Y
　　　　'If Brr(j, 1) >= Arr(k, 2) And Brr(j, 1) <= Arr(k, 1) Then SU = SU + 1 '判斷兩次,速度較慢
　　　　If Brr(j, 1) >= Arr(k, 2) Then If Brr(j, 1) <= Arr(k, 1) Then SU = SU + 1 '第一條件成立再判斷第二條件,較快
　　Next k
　　Crr(j, 0) = SU: SU = 0
Next j
[結果!B3].Resize(Cunt).Value = Crr
Application.Goto [結果!B3]
MsgBox Timer - TM
End Sub

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
5#
發表於 2015-8-29 22:47 | 顯示全部帖子
本帖最後由 准提部林 於 2015-8-29 22:48 編輯

Brr(j, 1) >= Arr(k, 2) 基準值(比較點) >= 列之最低價
Brr(j, 1) <= Arr(k, 1) 基準值(比較點) <= 列之最高價
　
結果表a欄因有〔浮點數〕問題，請使用=round(??,2)處理！
　
最低價小于７的只有四筆：第８０１∼８０４列
2008/10/27        6.68        6.79        6.68
2008/10/28        6.29        6.48        6.23
2008/10/29        6.67        6.67        6.52
2008/10/30        6.50        7.11        6.50
若從2008/11/21（第８２０列）往下統計，則基準值７以下應都為０，
若從第２列至全部統計，總數為：89502

程式碼並不難，多看幾次應可自行修改！
TEST03v2.rar (162.44 KB)
　

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
6#
發表於 2015-8-30 11:03 | 顯示全部帖子
回復 55# lcctno


〔基準值〕有小數點，很容易造成〔浮點數〕，已告知使用ROUND處理，
例如：公式計算後的數據雖然顯示（看起來）為：0.15，
　　　按Ｆ９檢查，實際為0.149999999，
　　　有時按Ｆ９，仍顯示0.15，有浮點數但肉眼看不出來，（結果表A1917的8550.60，就是這樣），
　　　往往造成計算的誤差，這是EXCEL的宿命，
　　　所以，有小數的數據，最好養成習慣加ROUND加工一下∼

Ａ３公式改為：
=IF(Data!K$4+Data!L$4*(ROW()-4) > Data!K$2, "", ROUND(Data!K$4+Data!L$4*(ROW()-3),2))　下刷到底

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
7#
發表於 2015-8-30 12:35 | 顯示全部帖子
回復 57# lcctno

=ROUND(IF(Data!K$4+Data!L$4*(ROW()-4) > Data!K$2, "", Data!K$4+Data!L$4*(ROW()-3)),2)
這公式到最後會有〔錯誤值#Value〕，是因遇空字符""，又將ROUND放在最外圈，下一式就ＯＫ，
=IF(Data!K$4+Data!L$4*(ROW()-4) > Data!K$2, "", ROUND(Data!K$4+Data!L$4*(ROW()-3),2))

excel公式及vba可能用的〔精準度〕不同，所以有時同一數值產生不同結果，
以A1917為例，公式：=IF(Data!K$4+Data!L$4*(ROW()-4) > Data!K$2, "", Data!K$4+Data!L$4*(ROW()-3))

F1917公式：=A1917=8550.6　→結果　TRUE

Sub test()
　MsgBox [結果!A1917] = 8550.6　　 '→執行結果：FALSE
End Sub

這不是我的專業，恕無法再深入解說∼

　

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
8#
發表於 2015-8-30 19:39 | 顯示全部帖子
本帖最後由 准提部林 於 2015-8-30 19:50 編輯

回復 60# ML089


全域陣列確實較快省資源!

MMULT在XP+OFFICE2000下, 最多可用到5643列, 再多就#VALUE,
不知其他版本可用到多少列?


＿＿登錄時都勾選了〔自動登錄〕，每次進來論壇還要再輸入帳號密碼，真不方便！
　

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
9#
發表於 2015-8-31 12:39 | 顯示全部帖子
回復 62# ML089


哈! 還是新版有料~~
謝謝！

之前都用奇摩知識+，現在版面一改已面目皆非，幾無excel專用效果！
excel-home非常專業，但台灣少人用，有時串串門子，
台灣比較專于excel論壇的，似乎只剩這裡，而各位板主功力也幾可幫忙大部份問題，所以也少上來（上來也是看看而已）！

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
10#
發表於 2015-8-31 12:46 | 顯示全部帖子
回復 64# lcctno


本來穿褲子（公式）嫌慢，改成裙子（vba）較快些，
現在想褲子再穿搭裙子，問題又回到原點，
公式範圍第一格留公式，其下複製後再貼成值（以５５樓範例檔為準）：
Sub 更新公式()
With [結果1!B4:B2562]
　　　[結果1!B3].Copy .Cells
　　　.Value = .Value
End With
End Sub

這樣只有第一格公式會影響運作∼∼

或如下：
Sub 更新公式2()
With [結果1!B3:B2562]
　　.Formula = "=IF(A3="""","""",SUMPRODUCT((A3<=資料列_最高價)*(A3>=資料列_最低價)))"
　　.Value = .Value
End With
End Sub

執行中須等待些時間（有如當機），完成後即不會影響其它操作！
　

TOP

        靜思自在 : 原諒別人就是善待自己。
12
返回列表 上一主題