麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 誰能幫這幾乎重複動作的VBA瘦身謝謝 [打印本頁]

作者: lcctno 時間: 2015-8-23 18:49 標題: 誰能幫這幾乎重複動作的VBA瘦身謝謝

本帖最後由 lcctno 於 2015-8-23 18:52 編輯

由於在下是vba初學者故嘗試將我使用函數寫的數百mb之excell檔使用錄製巨集的方式來將該檔瘦身雖然瘦身後可正常使用但我想應該程式碼也有簡化的可能性
我知道可以將  Rows("3:101").Select 改成 Rows("3:1001").Select 但會發生類似系統資源不夠的警告語故只好寫成一次只判斷100筆的資料但我目前的資料也接近6000筆了且還會繼續增加
希望有高手能幫助我簡化它並讓它能順利的執行到 10001筆 (為將來留後路) 謝謝了

目前瘦身的處理過程是將每一分頁指保留一列之函數使用vba將之複製並貼上99列函數後在將附製上之結果變成純文字再貼回原處依此類推...工作表.由"析1" 到"析10"  總共10分頁如附圖

[attach]21778[/attach]

分隔線++++++++++++++++++++++++++++++++++++++++++++++
'判斷列1之值是否在工作表"Data"對應之每日高低值的範圍內

Sub 判斷列()

'2~101

'製作判斷列
Sheets("析1").Select
Rows("2:2").Select
Selection.Copy
Rows("3:101").Select
ActiveSheet.Paste

'瘦身
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False

'製作判斷列
Sheets("析2").Select
Rows("2:2").Select
Application.CutCopyMode = False
Selection.Copy
Rows("3:101").Select
ActiveSheet.Paste

'瘦身
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False

  ...............
. ....略過很多比工程碼...............

'製作判斷列
Sheets("析10").Select
Rows("2:2").Select
Application.CutCopyMode = False
Selection.Copy
Rows("202:301").Select
ActiveSheet.Paste

'瘦身
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False

Sheets("Data").Select
End Sub

匯出之巨集
[attach]21779[/attach]

作者: ikboy 時間: 2015-8-24 07:18

Sub ZZ()
Dim ar, br
ar = Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")
For i = 0 To UBound(ar)
Select Case i
Case 0 To UBound(ar) - 1
      With Sheets(ar(i))
         .Rows(2).Copy .Rows("3:101")
         br = .Rows("3:4")
         .Rows("3:101") = br
      End With
Case UBound(ar)
      With Sheets(ar(i))
         .Rows(2).Copy .Rows("201:301")
         br = .Rows("201:301")
         .Rows("201:301") = br
      End With
End Select
Next
End Sub

作者: lcctno 時間: 2015-8-24 08:19

回復 2# ikboy

感謝您的熱心幫助但這樣執行只能比對300筆資料我是想要能執行到10001
還有想要請教可否能由外部之值例如於 "Data" 之分頁內加入2個輸入格可以輸入 [起始列數]="Data"之L4 [結束列數]="Data"之M4 做區段之比對這樣執行起來會省很多時間
在此先謝謝您的費心了

作者: ikboy 時間: 2015-8-24 08:49

回復 3# lcctno

Sub ZZ()
Dim ar, br, MyRng
Myrng = sheets("Data" ).[L4] & “:” & sheets("Data" ).[M4] Rem[起始列數]="Data"之L4    [結束列數]="Data"之M4
ar = Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")
For i = 0 To UBound(ar)
Select Case i
Case 0 To UBound(ar) - 1
      With Sheets(ar(i))
         .Rows(2).Copy .Rows(myrng)
         br = .Rows(myrng)
         .Rows(myrng) = br
      End With
Case UBound(ar)
      With Sheets(ar(i))
         .Rows(2).Copy .Rows("201:301") Rem 此處如此類推
         br = .Rows("201:301")
         .Rows("201:301") = br
      End With
End Select
Next
End Sub

作者: lcctno 時間: 2015-8-24 17:46

回復 4# ikboy

送上原檔請您試試不知道那裏出問題其中
[執行]之按鈕是我錄製的可以正常執行7000列之資料但執行7000列要花費很久的時間
[xx]之按鈕是您第一次寫的執行錯誤(非程式碼錯誤)
[yy]之按鈕是您第二次寫的執行錯誤(非程式碼錯誤)

還請您多照顧了謝謝您

[attach]21785[/attach]

作者: ikboy 時間: 2015-8-25 08:59

看到了問題是代碼中的中文字源於不同語系, 在您的檔案中亂碼了, 請手動更改
ar = Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")

作者: don4831 時間: 2015-8-25 10:28

透過工作管理員之處理程序可觀察EXCEL使用系統資源之情況。
我的環境：記憶體4G,可用2.9G，EXCEL用達299,000K時就會當。
只開【~test% -.xls】檔，不開其他檔，
(1)未執行前，EXCEL使用的系統資源：CPU使用率26%，記憶體用91,372K
(2)執行後，分析至6時，EXCEL使用的系統資源：CPU使用率61%，記憶體用209,336K
(3)分析至7時，EXCEL使用的系統資源：CPU使用率55%，記憶體用285,176K
(4)分析至8時，EXCEL使用的記憶體逾290,000K時，用ESC中斷作業。
公式相當耗資源，這支程式，幾乎所有的工作表都有公式，
如果不能強化系統資源，建議拆檔，將公式轉成程式和結果資料分開呈現。

作者: lcctno 時間: 2015-8-25 10:44

回復 6# ikboy

奇怪在我這端看起來很正常並沒有亂碼???
且都能執行

作者: lcctno 時間: 2015-8-25 10:50

本帖最後由 lcctno 於 2015-8-25 10:51 編輯

回復 7# don4831
先感謝您的用心與建議辛苦您了
就是因為這檔案執行起來真的很佔資源且又費時已勉強使用數年了 (因為我只會用函數寫) 所以才會貼文想改請高手幫助我改用VBA之工程寫法

作者: don4831 時間: 2015-8-25 17:06

透過起行及迄行執行，可超過萬筆copy：
Sub test()
Rem '起行=3，迄行=10000，執行時間：16:13:30~16:47:10
Application.ScreenUpdating = False
lineBegin = Worksheets("Data").Range("I4") '起行
lineEnd = Worksheets("Data").Range("J4") '迄行
For i = 1 To 10
      Worksheets("析" & i).Activate
      Rows(2).Copy
      For j = lineBegin To lineEnd
         Rows(j).PasteSpecial Paste:=xlPasteValues
      Next
      Rem 取消複製模式
      Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub

作者: lcctno 時間: 2015-8-25 18:25

回復 10# don4831

很感謝您的用心但發生了錯誤訊息如附圖
lineBegin = Worksheets("Data").Range("K4") '起行
lineEnd = Worksheets("Data").Range("L4") '迄行
這2行K4 L4是我改的那是配合我目前使用的輸入位置

[attach]21803[/attach]

作者: don4831 時間: 2015-8-27 14:56

我想你現在需要的，並不只是單純的程式開發，而是如何使用有限的系統資源建置大量的資料。
這是滿高階的問題解決技巧，無法細說，只能提供實例。
將錄製的巨集瘦身，它使用的系統資源還是很高，
目前在我的環境下，產生1000筆左右之資料，使用資源及執行效能尚可，
若是要產生3200筆的資料，耗用約20分30秒之後，會出現訊息：【記憶體不足】。
用我的程式，我是以1000筆為處理單位，耗用約07分產生64000筆資料，正常結束。
提醒：xls一個工作表最多只能有65536筆資料。
請在《Data》工作表之I4及J4儲存格輸入起始列及終止列。

Sub copyForNext()
Rem buffer = 999：每1000筆為1個處理單位
Application.ScreenUpdating = False
Call clearRow '清除舊資料
buffer = 999
lineBegin = Worksheets("Data").Range("I4") '起行
lineEnd = Worksheets("Data").Range("J4") '迄行
For i = 1 To 10
      Worksheets("析" & i).Activate
      Rows(2).Copy
      For j = lineBegin To lineEnd
         k = j + buffer
         Rows(j & ":" & k).Select
         Selection.PasteSpecial Paste:=xlPasteAll
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues
         j = k
      Next
      Rem 取消複製模式
      Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub

Sub clearRow()
Worksheets(Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")).Select
Rows("3:" & Rows.Count).Select
Selection.Clear
'以下動作，只是清除先前的選擇，以免人工要去取消選擇。
Range("A1").Select '目的：先前選擇區域的反影，只留選擇"A1"之儲存格
Worksheets("析1").Select '目的：先前選擇十個工作表，只留一個選擇"析1"之工作表
End Sub

[attach]21814[/attach]

作者: lcctno 時間: 2015-8-27 16:42

回復 12# don4831
可執行完畢但統計結果錯誤不知道那個地方有誤我還在找您提供的程式碼看問題出在那裏
謝謝您費時費力的幫助我

作者: don4831 時間: 2015-8-27 17:35

回復 11# lcctno
請確認輸入的值和資料型態是否為數字

作者: don4831 時間: 2015-8-27 17:40

回復 13# lcctno
我也正好要瞭解我的系統資源之極限，以便程式之開發，你的程式正好可以協助我進行，謝謝。

作者: lcctno 時間: 2015-8-27 17:42

本帖最後由 lcctno 於 2015-8-27 17:44 編輯

回復 12# don4831

找到原因了
執行第3~1002列時正常
當執行第1003~2002列時就不正常了看到的是貼上的值與執行第3~1002列之值相同
當執行第2003~3002列時同樣結果看到的是貼上的值與執行第3~1002列之值相同
應該以下也會是同樣的結果
我知道應該是貼的值選錯目標我想還是麻煩您除錯我實在是不會修改這麼深的問題謝謝您了

作者: lcctno 時間: 2015-8-27 21:26

本帖最後由 lcctno 於 2015-8-27 21:34 編輯

回復 12# don4831

Sub copyForNext()
Application.ScreenUpdating = True '因為要看動作是否正確
'Call clearRow '清除舊資料看能不能只清除當下要執行的地方否則之前之值就被清除了變成必須要從頭執行那就無法結省處理時間(因為每週增加於工作頁"Data"之列數只有少數幾列)

lineBegin = Worksheets("Data").Range("K4") '起行 我目前使用之位置
lineEnd = Worksheets("Data").Range("L4") '迄行 我目前使用之位置
buffer = Worksheets("Data").Range("M4")
Rem buffer = 工作頁"Data"內M4之值為1個處理單位  方便除錯及配合未來每週小量增加的"Data"  可減少執行時間

For i = 1 To 10
      Worksheets("析" & i).Activate
      Rows(2).Copy
      For j = lineBegin To lineEnd
         k = j + buffer - 1
         Rows(j & ":" & k).Select
         Selection.PasteSpecial Paste:=xlPasteAll
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues
         j = k
      Next
      Rem 取消複製模式
      Application.CutCopyMode = False
Next
Application.ScreenUpdating = True

'歸位並結束Sub
Sheets("Data").Select
End Sub

作者: lpk187 時間: 2015-8-27 23:11

回復 17# lcctno

既然都是向下copy可不只複製、貼上
何不考慮自動填滿AutoFill

Sub xx()
Dim j4%
j4 = Sheets("DATA").[j4]
For i = 1 To 10
With Sheets("析" & i)
dl = .[a65536].End(xlUp).Row
If j4 <> dl Then .Rows(dl & ":" & dl).AutoFill _
Destination:=.Rows(dl & ":" & j4), Type:=xlFillDefault
End With
Next
End Sub

複製代碼

作者: lcctno 時間: 2015-8-28 07:19

回復 18# lpk187
謝謝您的建議
如果使用自動填滿到終止列那7000列甚至10000列可能沒有幾台電腦能順利執行完成因為太佔電腦資源且每次都得浪費很多時間只為了在分頁"Data"中增加數列的資料而必須全部再運算一次且完全沒有選擇性

作者: don4831 時間: 2015-8-28 09:52

回復 17# lcctno

先處理第一個問題：
'Call clearRow '清除舊資料看能不能只清除當下要執行的地方否則之前之值就被清除了變成必須要從頭執行那就無法結省處理時間(因為每週增加於工作頁"Data"之列數只有少數幾列)
請問：你所謂的當下是什麼？你上次提到要自第3行起清除資料，我只是call它，以免新舊資料不分。

作者: lcctno 時間: 2015-8-28 10:03

回復 20# don4831
"當下" 是指只要清除正要貼值之區域也就是說其餘之前的值不要被清除
謝謝您的用心

作者: don4831 時間: 2015-8-28 10:21

我研判你需要的應是：
Sub clearRow()
Worksheets(Array("析1", "析2", "析3", "析4", "析5", "析6", "析7", "析8", "析9", "析10")).Select
lineBegin = Worksheets("Data").Range("K4") '起行
Rows(lineBegin & ":" & Rows.Count).Select '自你指定的起行清到最後
Selection.Clear
Range("A1").Select
Worksheets("析1").Select
End Sub

作者: lcctno 時間: 2015-8-28 10:30

回復 22# don4831
沒錯就是這樣我目前佈局情形如下圖

[attach]21833[/attach]

作者: lpk187 時間: 2015-8-28 11:13

回復 19# lcctno

你沒注意我寫的程式。只有幫你填滿每週需填滿的幾行。而且所需時間較少，就算填滿至65536都OK的
j4 = Sheets("DATA").[j4]''為終止行
dl = .[a65536].End(xlUp).Row為這週的開始行。

作者: lcctno 時間: 2015-8-28 11:27

回復 24# lpk187
謝謝您我不是沒有看而是看到的內容與我很低程度的"vba能力" 造成我的認知與實際剛好相反 (看不懂程式碼頭很大)
我真的只知道該步驟該怎麼進行但卻不會寫稍微複雜的VBA 雖然您有提供程式語法但對看不懂的人實在是只能說聲謝謝您因為還是不知道該擺在那裏 ....

作者: 准提部林 時間: 2015-8-28 12:23

光〔複製．貼上〕就要耗費大半天時間，尤其文字或公式更耗時，
使用陣列直接運算取出結果再貼入，因判斷值只有０及１，貼入時還算快，
雖是最基本的〔陣列．array〕運用，但對初學者也頗有難度，恕無法解說，參考即可：
[attach]21834[/attach]
　
若資料太多，可能造成記憶體不足問題，試試看！
我只插花，此論壇各板主皆是專業高手，可請求其協助！
　
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

作者: lcctno 時間: 2015-8-28 12:53

本帖最後由 lcctno 於 2015-8-28 12:55 編輯

回復 26# 准提部林

是能執行且僅僅數秒也太快了但出來的值錯誤(目前股價累計發生率=100%) 我沒能力了解這麼深的語法故無法除錯

[attach]21836[/attach]

[attach]21837[/attach]

發生率=100%
[attach]21838[/attach]

作者: azrael19 時間: 2015-8-28 13:58

你可以將數據貼上並修改I4及J4日期範圍試試看[結果]工作表運算是否可以符合你預期。
先說附檔並不是用您所期望的方式去修改，運算結果可能也不是你想要的結果，僅供參考...
[attach]21839[/attach]

作者: 准提部林 時間: 2015-8-28 14:01

程式只取得各股價參數的符合次數,並輸出至〔結果〕表的ＡＢ欄，
至於ＣＤ欄如何計算〔發生率〕，須自行去套公式！

作者: azrael19 時間: 2015-8-28 14:51

回復 27# lcctno

你可以將數據貼上並修改I4及J4日期範圍試試看[結果]工作表運算是否可以符合你預期。
先說附檔並不是用您所期望的方式去修改，運算結果可能也不是你想要的結果，僅供參考...
剛剛28#發的公式只能算到第310列，這是修正檔
[attach]21841[/attach]

作者: lcctno 時間: 2015-8-28 15:40

回復 28# azrael19
感謝您的提供但裏面沒任何函數
結果當然沒有改變

[attach]21843[/attach]

[attach]21844[/attach]

作者: lcctno 時間: 2015-8-28 15:44

回復 29# 准提部林

謝謝您但那不是我要的我目前都能很正常且檔案也變的很小只是想把它弄得更有人性化

作者: lcctno 時間: 2015-8-28 16:29

回復 30# azrael19
真的是高手原來是用函數寫的我還以為您的vba忘了存原檔案內
但結果是不太一樣? 應該是比對方式不同造成的我有將比對之函數寫在附註內感謝您您那檔執行速度超快的希望您能找出原因

這是我的使用現狀
[attach]21845[/attach]

已經加上data之檔案
[attach]21846[/attach]

作者: lcctno 時間: 2015-8-28 16:59

回復 30# azrael19

先說聲 :對不起
高手您的OK 是我沒有完全執行完 (有更改間距=您設的值) 但忘了做整套的比對所以才會數據不同之前回傳於您之程式執行結果與我的完全相同
我再多試一些較長時間的測試我想應該結果也會相同
真的沒想到用函數就可以完成

[attach]21847[/attach]

作者: lcctno 時間: 2015-8-28 18:42

回復 30# azrael19

目前有發現個很小的問題只是我沒能力修改那麼複雜的函數
目前經過數種方式的比對 "data"內之總數與"結果"內之發生次數都完全一樣但統計後之"目前股價累計發生率"有小許的差距可能是算式不同所致
可否麻煩您將"目前股價累計發生率" 改成如附件上放的方式事實上我也發現之前我用的計算"目前股價累計發生率"的方式不太好還好都只有小數點以下的誤差

謝謝您幫了我的大忙

[attach]21848[/attach]

作者: azrael19 時間: 2015-8-28 22:03

回復 azrael19

目前有發現個很小的問題只是我沒能力修改那麼複雜的函數
目前經過數種方式的比對 "da ...
lcctno 發表於 2015-8-28 18:42

試試看...
[attach]21859[/attach]

作者: lcctno 時間: 2015-8-28 23:14

本帖最後由 lcctno 於 2015-8-28 23:15 編輯

回復 36# azrael19
感謝您目前只測試2個不同族群的data 我很高興結果"完全正確" 您的函數真的太強了

若方便的話可否麻煩使用最白話的方式告訴低能的我您在"結果"分頁內那3個函數的意思

區間=COUNTA(A:A)-1 值是正確但為何是-1 而不是-2( 因為我看到有2個是非數字列) ?

資料列_最高價 '=OFFSET(INDIRECT(ADDRESS(IF(Data!$I$6="",2,Data!$I$6),3,,,"Data")),,,IF(Data!$J$6="",COUNTA(INDIRECT("Data!$A:$A"))-1,Data!$J$6-IF(Data!$I$6="",2,Data!$I$6)+1),) 這個我完全不知道是什麼

資料列_最低價 '=OFFSET(資料列_最高價,,1,,) 這個我也完全不知道是什麼

謝謝您了

作者: azrael19 時間: 2015-8-29 09:04

回復 azrael19
感謝您目前只測試2個不同族群的data 我很高興結果"完全正確" 您的函數真的太強了

若 ...
lcctno 發表於 2015-8-28 23:14

1.COUNTA是計算範圍中不是空白的儲存格數目，-1就是減掉儲存格A2標題指數(股價)。
2.其實組合公式看不懂時你可以先嘗試著分拆成一小段方式並輸入儲存格看輸出結果就很好理解，例如:
(a)
  公式: =ADDRESS(8,6) 就等於字串 "$F$8"。
  公式: =ADDRESS(8,6,,,"Data") 就等於字串 "Data!$F$8"。
(b)當Data!I6 值是18時:
  公式: =ADDRESS(Data!$I$6,3,,,"Data") 就等於字串 "Data!$C$18"。
  公式: =INDIRECT(ADDRESS(Data!$I$6,3,,,"Data")) 就是參照儲存格 Data!C18。
(c)當Data!I6 值是7，Data!J6值是306
  公式: =OFFSET(INDIRECT(ADDRESS(Data!$I$6,3,,,"Data")),,,Data!$J$6-Data!$I$6+1,)
  就是指向儲存格範圍 Data!C7:C306。
(d)公式中使用到IF函數部分就是針對Data!$I$6或Data!$J$6是空白時的例外處理方式。
3.例如自定名稱資料列_最高價是指向儲存格範圍 Data!C7:C306
  公式: =OFFSET(資料列_最高價,,1,,) 就是指向儲存格範圍 Data!D7:D306

參考資料:
COUNTA
ADDRESS
INDIRECT
OFFSET
評估值公式
自訂名稱

作者: lcctno 時間: 2015-8-29 09:19

回復 36# azrael19
經測試股票有發現工作頁"Data"內H2之總數有誤
經極小化來檢視發現您漏了將等於列之值取樣如附件有紫色的地方請看一下
昨天我只測試指數並沒發現與我的統計有異但今天測試股價時發現了這問題
麻煩請您將函數修改一下謝謝您

[attach]21861[/attach]

作者: azrael19 時間: 2015-8-29 09:38

回復 azrael19
經測試股票有發現工作頁"Data"內H2之總數有誤
經極小化來檢視發現您漏了將等於列之值 ...
lcctno 發表於 2015-8-29 09:19

將結果工作表 A4 公式由=A3+Data!$L$4改成=ROUND(A3+Data!$L$4,2)下拉自動填滿公式

作者: lcctno 時間: 2015-8-29 11:58

回復 40# azrael19

看起來很妥當了
我看您要求改的部分是4捨5入看起來那些格內值並沒有改變但為何比對結果就正確了???
另外為何我只要開啟您的檔案我未做任何動作便關上它就會提示資料已更改問我要不要存檔???
為何您的檔案超級小且執行起來也很快(跟我寫的比) ?
您真的是高手中的高手

謝謝您了

作者: azrael19 時間: 2015-8-29 14:23

回復 azrael19

看起來很妥當了
我看您要求改的部分是4捨5入看起來那些格內值並沒有改變但為何比對 ...
lcctno 發表於 2015-8-29 11:58

1.浮點數誤差，請參考 https://support.microsoft.com/zh-tw/kb/214118
所以也可以將 A4公式改成: =TRUNC(A3+Data!$L$4,2)，這是您原始檔所使用的方式。
2.其實您所提供的-test% -.zip就會了，這個我也不太知道...
(可能打開檔案時的運算超過一定數量範圍或是使用到特定功能就會這樣，例如您的原始檔我只要將WebQuery移除就不會問了...)
3.因為使用的儲存格少自然就小，運算少自然等待時間就短。

我不是高手，如果有常在論壇爬文，同時將版主們的回覆親自動手做過一遍就可以很快學到這些技巧，只是用看的大概很快就忘光了...
還有你應該要感謝是前面回覆您問題的前輩，如果一開始就先將公式簡化再來問如何用VBA瘦身，那個運算速度會比我給你的快多了

作者: lcctno 時間: 2015-8-29 14:52

回復 42# azrael19
感謝您的用心我從沒正式的上過PC相關的課只為了安心的投資股票
所以才土法煉鋼用最簡單基本的函數寫了數個"大巨蛋"
那些我寫的"大巨蛋" 居然有單一檔就超過700mb 執行起來還真慢所以也是為了將檔案瘦身才來麻辣家族求救
來到麻辣家族還算真的很受益謝謝您大力的幫助我真心的感謝您
您說用VBA會更快? 您完成的已經很快了我還真想看看vba能快到什麼程度
您說如果我再用您幫我完成的檔案再發一次帖會不會被人當成灌水發帖?

作者: azrael19 時間: 2015-8-29 15:58

回復 azrael19
感謝您的用心我從沒正式的上過PC相關的課只為了安心的投資股票
所以才土法煉鋼用最簡 ...
lcctno 發表於 2015-8-29 14:52

還是不要好了，先說我沒有惡意您看了千萬別誤會
這裡是讓大家學習釣魚的技巧及分享學習經驗，當大家發現你只是想請人幫你釣魚，很快你的問題就得不到任何回覆...
基本上等你有能力看懂前面回覆您問題前輩的程式碼，再提出問題會比較適當。
還有與主題無關的回覆就算灌水，我現在的回覆就算了，所以您千萬別再回覆我

作者: ML089 時間: 2015-8-29 16:53

回復 43# lcctno

data!J2 可以直接帶函數比較簡單一些
=FORECAST(I2,OFFSET(結果!D1,MATCH(I2,結果!A:A,1),,-2),OFFSET(結果!A1,MATCH(I2,結果!A:A,1),,-2))

FORECAST(x,known_y's,known_x's)
X 是您要預測一個數值的資料點。
Known_y's 是因變數陣列或資料範圍。
Known_x's 是自變數陣列或資料範圍。

原 data!J2 公式
=IF(ISERROR(LOOKUP(I2,OFFSET(結果!$A$3,,,結果!$E$2,),ROW(OFFSET(結果!$A$3,,,結果!$E$2,)))),"--",IF(LOOKUP(I2,OFFSET(結果!$A$3,,,結果!$E$2,),ROW(OFFSET(結果!$A$3,,,結果!$E$2,)))>=結果!$E$2+2,1,VLOOKUP(I2,IF({1,0},OFFSET(結果!$A$3,,,結果!$E$2,),OFFSET(結果!$D$3,,,結果!$E$2,)),2)+(I2-LOOKUP(I2,OFFSET(結果!$A$3,,,結果!$E$2,)))*LINEST(OFFSET(INDIRECT("結果!D"&LOOKUP(I2,OFFSET(結果!$A$3,,,結果!$E$2,),ROW(OFFSET(結果!$A$3,,,結果!$E$2,))),1),,,2,),OFFSET(INDIRECT("結果!A"&LOOKUP(I2,OFFSET(結果!$A$3,,,結果!$E$2,),ROW(OFFSET(結果!$A$3,,,結果!$E$2,))),1),,,2,))))

作者: ML089 時間: 2015-8-29 17:28

回復 43# lcctno

SUMPRODUCT函數很慢，需減少使用
A3:A2562 公式範圍太大使用計算變得很慢，實際才使用到A743

建議改為

結果!
A3 =IF(Data!N$2+Data!O$2*(ROW()-4) > Data!K$2, "", Data!N$2+Data!O$2*(ROW()-3))
B3 =IF(A3="",0,SUMPRODUCT((A3<=資料列_最高價)*(A3>=資料列_最低價)))

作者: 准提部林 時間: 2015-8-29 18:58

為何我只要開啟您的檔案我未做任何動作便關上它就會提示資料已更改問我要不要存檔???
OFFSET,INDIRECT,NOW,TODAY....等等函數, 都會造成這個提示!

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

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

作者: lcctno 時間: 2015-8-29 19:13

回復 47# 准提部林
希望您有辦法幫我若可以的話附上說明我也很想學

附上貴人們的指導後完成的檔案希望能多提供改善的地方謝謝您

[attach]21864[/attach]

作者: 准提部林 時間: 2015-8-29 20:48

用上次VBA修改如下（只列出結果表Ｂ欄次數，其他不處理）：
[attach]21865[/attach]

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

作者: lcctno 時間: 2015-8-29 21:45

本帖最後由 lcctno 於 2015-8-29 21:47 編輯

回復 49# 准提部林

[attach]21867[/attach]

可能是判讀的程式碼不同所至請看附件內紫色的部分由於這執行檔是能要讓股票及指數來使用還請費心了

謝謝您的辛勞

如果基準值(比較點) >= 列之最低價同時 <= 列之最高價就給 1
也就是說只要基準值(比較點)有在區間內就給1
=IF(AND(基準值>=Data!D3,基準值<=Data!C3),1,"")

作者: 准提部林 時間: 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

程式碼並不難，多看幾次應可自行修改！
[attach]21868[/attach]
　

作者: lcctno 時間: 2015-8-29 23:32

回復 51# 准提部林
您這次的結果是正確的我很奇怪不知道我這邊那裏出問題這次執行的結果又跟您修改過的一樣我從早上幾乎(只有短暫的離開) 一直坐在電腦前可能頭腦不清醒了我頭真的大了 ...
看來還有得忙了
謝謝您的幫助我說一下我的內心話有一些東西對於會的人來說認為是很淺顯的但對初接觸者真的是比登天還難請原諒我的無知因而造成您的困擾謝謝您了

作者: lcctno 時間: 2015-8-30 02:22

本帖最後由 lcctno 於 2015-8-30 02:24 編輯

回復 46# ML089

感謝版大再次的提醒
我可能因為從昨天6點多弄到現在
已超過20小時未休息
應該老人家精神無法負荷
10幾個檔案在瘦身
應該是忙中有錯
麻煩您看這檔案是否如您告知及是否已正確的修改了
謝謝您的關愛

我該睡了晚安

[attach]21869[/attach]

作者: lcctno 時間: 2015-8-30 08:35

回復 51# 准提部林
用您給的檔去試問題更多所以我就用我最後經過數位高手指導後所完成的檔案下去加上您那vba工程碼
執行結果還是無法完全吻合不知道那裏出問題麻煩高手的您幫忙分析一下
謝謝您的照顧

[attach]21870[/attach]

作者: lcctno 時間: 2015-8-30 09:56

回復 51# 准提部林

抱歉剛剛發現送錯檔了
54樓的不對

[attach]21871[/attach]

作者: 准提部林 時間: 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))　下刷到底

作者: lcctno 時間: 2015-8-30 11:16

回復 56# 准提部林
看來應該是ok了
我之前有試過 ROUND(原來的內容,2) 結果複製到底端空白處就出問題了
以及 trunc 2位數結束都是一樣底下部分有亂碼
謝謝您的用心幫助我
請問為何同樣的數字函數與vba 怎麼會看起是不一樣的比較值
有勞您了謝謝

作者: 准提部林 時間: 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

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

　

作者: Scott090 時間: 2015-8-30 14:02

回復 57# lcctno

計算不一致的地方是 [Data!D4960] 8550.60，比對 [結果!A1917] 的 8550.60
剛好是在比對的邊界值而造成浮點算數的問題
假如 VBA 程式的比較式做一個處理就可以了
Sub 分析發生次數()
   Dim Arr, Brr, Cunt&, Crr%(), R&, X&, Y&, TM, j%, k&, SU%
   Const Zero = 0.00000001 '這是一個很小而不影響  "實用上的精度"  的數值
..............
..........
  ' If Brr(j, 1) >= Arr(k, 2) Then If Brr(j, 1) <= Arr(k, 1) Then SU = SU + 1
'改為：
   If Brr(j, 1) >= Arr(k, 2) - Zero Then If Brr(j, 1) <= Arr(k, 1) + Zero Then SU = SU + 1

..................
.........
End sub

以上請參考

作者: ML089 時間: 2015-8-30 18:08

回復 53# lcctno

原來的也是OK，修改一些公式感覺快一些。

[attach]21874[/attach]

作者: 准提部林 時間: 2015-8-30 19:39

本帖最後由准提部林於 2015-8-30 19:50 編輯

回復 60# ML089

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

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

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

作者: ML089 時間: 2015-8-30 19:57

回復 61# 准提部林

MMULT 在2007版
1. 測試 1000000X2 及 2X1000000 都可以跑
2. 測試 4000X4000以上就會出現公式資源不足的訊息

作者: ML089 時間: 2015-8-30 20:01

回復 61# 准提部林

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

我的會自動登錄(WIN10+CHROME)
但一段時間(好像一個星期吧)就會要求重新登錄，若你不常上來就會感覺每次登錄都要重新輸入帳號密碼。

作者: lcctno 時間: 2015-8-30 22:59

本帖最後由 lcctno 於 2015-8-30 23:00 編輯

回復 47# 准提部林

請問有沒有辦法讓我這檔案 (除了拆單外)
能夠於運算完後就將某個功能關掉好讓它把資源讓出來
也就是說在執行同樣那檔但不需要它在即時運算
因為統計完後就照表操課了只是還會需要用到別的部分
有勞您了謝謝
我現在是"函數+vba" double check 也比較放心

作者: 准提部林 時間: 2015-8-31 12:39

回復 62# ML089

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

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

作者: 准提部林 時間: 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

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

作者: lcctno 時間: 2015-8-31 14:46

回復 66# 准提部林
報告高手
執行中須等待些時間（有如當機）
執行這項用不到4秒很值得
但是有一個問題儲存離開後再開啟發現若改變統計日期之區間就不會改變數據且打開時並沒有明顯的運算動做這樣那檔案就是只能一次性使用(除非是不想改變統計區間或輸入其他股票的data 有沒有辦法加一個開關隨時可隨性而用
很報歉較慢回覆因在做測試那執行檔 (由於看不懂只能實做看現象) 所以花了不少時間

.Formula = "=IF(A3="""","""",SUMPRODUCT((A3<=資料列_最高價)*(A3>=資料列_最低價)))"
請麻煩告訴我有這行是什麼用途?

謝謝您的幫忙

作者: 准提部林 時間: 2015-8-31 16:12

回復 67# lcctno

但是有一個問題儲存離開後再開啟發現若改變統計日期之區間就不會改變數據且打開時並沒有明顯的運算動做
這樣那檔案就是只能一次性使用(除非是不想改變統計區間或輸入其他股票的data 有沒有辦法加一個開關隨時可隨性而用
想來源資料變動，公式自動變動，那就是〔常駐公式〕，也是因這個而讓操作檔案礙手，
所以，資料變動，只能提供〔以VBA刷新〕方式得到最新結果，，因此，兩種VBA只是用來驗證兩程結果是否一致？
若資料不多，就保持公式常態，連VBA都可省去了！
若資料很多又要保持公式，恕無方法讓檔案不卡（關掉自動重算，與使用VBA同樣效果，但會造成其它公式無法運算，不是好方法），

.Formula = "=IF(A3="""","""",SUMPRODUCT((A3<=資料列_最高價)*(A3>=資料列_最低價)))"
這不是附檔中的公式嗎？只是利用VBA去置入！也可用〔錄製〕取得FormulaR1C1的公式！

有些問題需要累積經驗才懂，一時無法說太詳細，請慢慢參酌～～
　

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)