Board logo

標題: 加權平均數VBA [打印本頁]
作者: 518587    時間: 2014-4-12 15:33     標題: 加權平均數VBA

請問各位大大，如何寫出加權平均數的VBA

由於加權平均數循環計算，想要嘗試的寫，但是有很多語法不清楚，不會用特別專業只會簡單的語法使用。
想詢問以下語法在VBA要怎麼打

計算三年(365*3筆資料)的周一到周七算出一個加權平均數
1、如何抓出周一到周七數值的平均數
2、平均值在減掉原本的數算出絕對距離
3、抓出周一到周七最大值與最小值然後減去平均值
4、在VBA使用ln、Exp
作者: 518587    時間: 2014-4-12 19:46

回復 1# 518587


各位大大，拜託幫幫我~~

我已經寫好了!!!
但是很奇怪

可以跑但是一直出錯，也不知道是哪裡的原因

而且如果把工作表裡面的D到K欄的資料全刪掉，就完全不能跑了...

可否幫我看看到底是哪裡出問題了呢?!!!!
附件有檔案
[attach]17997[/attach]
作者: 518587    時間: 2014-4-12 20:19

回復 2# 518587


    問題

為什麼每次點的答案都不一樣呢?!
作者: GBKEE    時間: 2014-4-12 20:38

回復 2# 518587

試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng As Range, First_1 As String
  4.     Range("D:G") = ""
  5.     Set Rng = Range("b:b").Find(1, lookat:=xlWhole) 'B欄中尋找 週一.
  6.     First_1 = Rng.Address
  7.     Do
  8.         With Rng(1).Offset(, 1).Resize(7)
  9.             .Cells(1, 2) = Application.WorksheetFunction.Average(.Cells)
  10.             .Cells(1, 3) = "" '平均值在減掉原本的數算出絕對距離 公式??
  11.             .Cells(1, 4) = (Application.WorksheetFunction.Max(.Cells) + Application.WorksheetFunction.Min(.Cells)) - Application.WorksheetFunction.Average(.Cells)
  12.         End With
  13.         Set Rng = Range("B:B").FindNext(Rng(1)) '尋找下一個週一
  14.     Loop Until First_1 = Rng(1).Address         '下一個週一的位置=第一個週一的位置(回到第一個週一的位置)
  15. End Sub
複製代碼
作者: 518587    時間: 2014-4-12 21:19

回復 4# GBKEE


  對不起，不太對!是我說明的不清楚...不好意思!!

那我說明整個流程好了!

要算出"週加權平均數"(星一到星期七)

1.先計算周一到周七的平均數=AvgOld                      (出現一個數)
2.將原本數量減掉AvgOld=Xik 加上絕對值                  (出現七個數)
3.找出週一到周七最大值減掉AvgOld=Dpk                  (出現一個數)
4.找出週一到周七最小值減掉AvgOld=Dnk (絕對值)      (出現一個數)
5.Dnk/Dpk=Ri                      (出現一個數)
6.ck=(-(Dpk^2)/ln(Ri))                      (出現一個數)
7.f=exp(-(Xik^2)/ck)                            (出現七個數)
8.W=f/f的加總                      (出現七個數)
9.AvgNew=SUMPRODUCT(W*原始數量)                               (出現一個數)
10.如果 AvgOld-AvgNew>0.1 (加上絕對值)的話 ，新的平均值就必須取代舊的，然後回到第二步重複計算到小於0.1



這是我要寫的語法流程，不知道說明可以嗎!?
拜託你了!!!!!!!
作者: GBKEE    時間: 2014-4-13 15:14

本帖最後由 GBKEE 於 2014-4-13 19:32 編輯

回復 5# 518587
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng(1 To 2) As Range, i As Integer
  4.     Dim f(1 To 7), Xik(1 To 7)
  5.     Dim ii As Integer
  6.     On Error Resume Next   '程式碼有錯誤時 繼續下一行程式碼(不理會)
  7.     With ActiveSheet       '指定工作表
  8.         .Range("D:k") = ""
  9.         .Range("b:b").Cells.Replace 1, "=aaa", lookat:=xlWhole        '範圍中的儲存格值 = 1, 修改為不存在的公式,造成錯誤值
  10.         Set Rng(1) = .Range("b:b").SpecialCells(xlCellTypeFormulas, xlErrors)  '設定變數為這範圍中有錯誤值的特殊儲存格
  11.         Rng(1).Value = 1    '特殊儲存格的值恢復 = 1
  12.     End With
  13.     With Rng(1)
  14.         For i = 1 To .Areas.Count        'Areas 屬性 傳回 Areas 集合，此集合代表多重範圍中的所有範圍
  15.             With .Areas(i).Cells(1, 2).Resize(7)      '一週次數量範圍
  16.                 '.Cells(1,2) 'D欄 ** 1.先計算周一到周七的平均數 = AvgOld
  17.                 .Cells(1, 2) = Application.Average(.Cells)
  18.                 'AvgOld
  19. A:
  20.                 '.Cells(1,3) 'E欄 ** 2.將 原本數量 減掉AvgOld=Xik 加上絕對值(出現七個數)
  21.                 For ii = 1 To 7   '.Cells(ii, 1) C欄: 原本數量
  22.                     '.Cells(1,7) 'I欄 ** 6.ck=(-(Dpk^2)/ln(Ri))       (出現一個數)
  23.                     .Cells(ii, 3) = Abs(.Cells(ii, 1) - .Cells(1, 2))
  24.                     'Xik
  25.                     Xik(ii) = .Cells(ii, 3)   '
  26.                 Next
  27.         
  28.                 '.Cells(1,4) 'F欄 ** 3.找出週一到周七最大值減掉AvgOld=Dpk   (出現一個數)
  29.                 .Cells(1, 4) = Application.Max(.Cells) - .Cells(1, 2)
  30.                 'Dpk
  31.                
  32.                 '.Cells(1,5) 'G欄 ** 4.找出週一到周七最小值減掉AvgOld=Dnk (絕對值)  (出現一個數)
  33.                 .Cells(1, 5) = Abs(Application.Min(.Cells) - .Cells(1, 2))
  34.                 'Dnk
  35.                
  36.                 '.Cells(1,6) 'H欄 ** 5.Dnk/Dpk=Ri   (出現一個數)
  37.                 .Cells(1, 6) = .Cells(1, 5) / .Cells(1, 4)
  38.                 'Ri
  39.             
  40.                 '*** 到 A578 時 H578 = 1 Ln(.Cells(1, 6))=0
  41.                 '*** 分母=0 不可除 的錯誤  ***************
  42.                 '*** 接下的數字會有錯誤    ***************
  43.                 '.Cells(1,7) 'I欄 ** 6.ck=(-(Dpk^2)/ln(Ri))       (出現一個數)
  44.                 .Cells(1, 7) = -(.Cells(1, 4) ^ 2) / Application.Ln(.Cells(1, 6))
  45.                 'ck
  46.                
  47.                 '.Cells(1,8) 'J欄 ** 7.f=exp(-(Xik^2)/ck)          (出現七個數)
  48.                 For ii = 1 To 7
  49.                     .Cells(ii, 8) = Application.Evaluate("Exp(" & -(Xik(ii) ^ 2) / .Cells(1, 7) & ")")
  50.                     'f
  51.                     'VBA 不支援 工作表函數 Exp
  52.                     'Evaluate 方法 將 Microsoft Excel 名稱轉換成物件或者值。
  53.                     f(ii) = .Cells(ii, 8)
  54.                 Next
  55.         
  56.                 '.Cells(1,9) K欄 ** 8.W=f/f的加總         (出現七個數)
  57.                 For ii = 1 To 7
  58.                     .Cells(ii, 9) = f(ii) / Application.Sum(f)
  59.                     'W
  60.                 Next
  61.                 '.Cells(1,10) L欄 ** 9.AvgNew=SUMPRODUCT(W*原始數量)    (出現一個數)
  62.                 Set Rng(2) = .Cells(1, 9).Resize(7)     'W 的範圍
  63.                 .Cells(1, 10) = Application.SumProduct(Rng(2), .Cells)     'AvgNew
  64.                 '10.如果 AvgOld-AvgNew>0.1 (加上絕對值)的話 ，新的平均值就必須取代舊的，然後回到第二步重複計算到小於0.1
  65.                 'If Abs(.Cells(1, 2) - .Cells(1, 9)) > 0.1 Then GoTo A:  '回到第2步驟
  66.                 '*********?????????????????????
  67.                 '然後回到第二步重複計算到小於0.1
  68.                 '如何計算到小於0.1??
  69.                 '*******************************
  70.             End With
  71.         Next
  72.     End With
  73. End Sub
複製代碼
作者: 518587    時間: 2014-4-13 16:56

回復 6# GBKEE


以新算出來的加權平均取代原本的加權平均數
然後再繼續算新的加權數與數職的距離...等繼續算下去，最後又會有一個加權平均數算出來，
然後在與上次的加權數比較，誤差<0.1就停止，如果>0.1就在重複做

是這樣的意思!!!!
作者: 518587    時間: 2014-4-13 17:13

回復 6# GBKEE


  我最後改成這樣，但是為什麼沒有往回跑再重新計算呢?!是哪裡有錯嗎?!
請版大麻煩你幫我看看~~~~~!!!!

這是就是上一個回復的意思。

       If Abs(.Cells(1, 2) - .Cells(1, 10)) > 0.1 Then
            Cells(1, 11) = Abs(.Cells(1, 2) - .Cells(1, 10))
            Cells(1, 2) = Avg
             GoTo A
        End If


問D欄不適應該是Cells(X,4)嗎?!怎麼是Cells(X,2)呢?!
作者: 518587    時間: 2014-4-13 17:27

回復 6# GBKEE


不好意思，又出現了一些問題
請問一下
我將VBA程式碼貼到其他的地方無法執行，
怎麼樣才可以讓每個工作表都可以執行這段程式碼?!
作者: GBKEE    時間: 2014-4-13 19:40

回復 9# 518587

沒有加 .
  1. If Abs(.Cells(1, 2) - .Cells(1, 10)) > 0.1 Then
  2.     .Cells(1, 11) = Abs(.Cells(1, 2) - .Cells(1, 10))
  3.     .Cells(1, 2) = Avg
  4.     GoTo A
  5. End If
複製代碼
問D欄不適應該是Cells(X,4)嗎?!怎麼是Cells(X,2)呢?!
  1. Set Rng(1) = .Range("b:b").SpecialCells(xlCellTypeFormulas, xlErrors)
  2.     With Rng(1) -> Range("b:b")為 B欄
  3.         For i = 1 To .Areas.Count-> For i = 1 To Rng(1).Areas.Count
  4.            With .Areas(i).Cells(1, 2).Resize(7)   ->With Rng(1).Areas(i).Cells(1, 2).Resize(7)
  5.           ' 所以    .Cells(X,1)  -> C 欄
  6.         '所以    .Cells(X,2)  -> D 欄
複製代碼
怎麼樣才可以讓每個工作表都可以執行這段程式碼?!
  1.     Sub Ex()
  2.        With ActiveSheet   '(作用中的工作表)
  3.        '這裡有指定工作表為作用中的工作表,每張工作表可以使用的
複製代碼
作者: 518587    時間: 2014-4-13 22:30

回復 10# GBKEE


不好意思!!!!
我加上那個IF語法後vba都無法回應是怎麼了嗎?!
為什麼會這樣呢?!

問最後一個可以讓語法可用在各個工作表的語法要放在哪裡呢?!
作者: 518587    時間: 2014-4-13 22:37

回復 10# GBKEE


不好意思，我還是用不出來
不知道能不能請版大幫幫我，看一下到底哪出問題以及加入能夠讓各工作表都可以使用的語法

拜託拜託.....!!!!
作者: GBKEE    時間: 2014-4-14 06:22

本帖最後由 GBKEE 於 2014-4-14 06:24 編輯

回復 12# 518587
要認識VBA ,程式區的主題要多看.

[attach]18005[/attach]
  1. '10.如果 AvgOld-AvgNew>0.1 (加上絕對值)的話 ，新的平均值就必須取代舊的，然後回到第二步重複計算到小於0.1
  2.                 If Abs(.Cells(1, 2) - .Cells(1, 10)) > 0.1 Then
  3.                     .Cells(1, 11) = Abs(.Cells(1, 2) - .Cells(1, 10))
  4.                     .Cells(1, 2) = Avg   'Avg的公式???
  5.                     GoTo A
  6.                 End If
複製代碼
作者: yen956    時間: 2014-4-14 09:08

回復 4# GBKEE
很棒、很完整的 Find, FindNext 的使用範例, 收下, 謝謝版主!!
作者: 518587    時間: 2014-4-14 11:46

回復 13# GBKEE


版大，你好!!!!
對不起，我的問題這麼多....一直麻煩版大真的很不好意思!!!

附件有附上檔案，出現了以下的問題:
1、我在最上面加入了欄位的字串名稱，但是為什麼只出現L、M欄的字串
2、版大如果下在開啟後執行是可以跑得，但是如果把下面的判斷式的註解拿掉，開始執行判斷式就會出現問題
       出現的問題有
      (1) 工作表1的那是直接用手打計算出的結果，跟VBA跑出來(工作表5)的結果不相同，為什麼呢?!是因為VBA計算數值不一樣嗎?
      (2)執行的時候，他停不下來，必須強制停止，怎麼樣才能夠讓他自動停止?
      (3)執行停止後，查看程式結果，上面有計算出來，但是下面到了一個地方以後全部都沒有出現，為什麼呢?!






[attach]18010[/attach]
作者: 518587    時間: 2014-4-15 00:03

回復 13# GBKEE


你好!!!!
感謝你的幫忙，我已經做出來了迴圈!
但是出現了一個問題就是
他只會執行到417列之後的都會出錯，但是把417之前的移除在執行程式是可以執行的
想請問為什麼會這樣呢?!
作者: GBKEE    時間: 2014-4-15 05:42

回復 16# 518587
6# 中有註解
  1.                '*** 到 A578 時 H578 = 1 Ln(.Cells(1, 6))=0

  3. 41.                '*** 分母=0 不可除 的錯誤  ***************

  5. 42.                '*** 接下的數字會有錯誤    ***************
複製代碼
作者: 518587    時間: 2014-4-15 10:14

回復 17# GBKEE


可是他是到A417欄就沒有跑下去了!!
然後我把1到416的移到其他地方，
第417欄位移到第2爛後面的一起移動，
在一次跑VBA是可以跑得，而且也會停止，不會停到578欄

依版大的專業來看，這是什麼樣的問題呢?!
我始終找不到問題...
作者: 518587    時間: 2014-4-15 17:07

回復 17# GBKEE


  檔案在附件中!!!

全部的那個跑會斷在417欄
然後我將1~416跟417以後的拆成兩個工作表
發現1~416的會一直跑不會停
417之後的是可以跑出結果的

想請版大幫我看看到底是哪一部分出了問題!!!!

[attach]18024[/attach]
作者: GBKEE    時間: 2014-4-16 05:49

回復 19# 518587
  1. .Cells(1, 11) = Abs(.Cells(1, 2) - .Cells(1, 10))
  2. Debug.Print .Cells(1, 11).Address & " : " & .Cells(1, 11)  '加上這行查看.Cells(1, 11)的值
  3. GoTo A
複製代碼
[attach]18031[/attach]

Debug.Print 察看到 前段到M410 一直是>0.1
跳不出 If .Cells(1, 11) > 0.1 Then 的判斷
  1. $M$410 : 1.11185372875004
  2. $M$410 : 1.11185372875005
  3. $M$410 : 1.11185372875006
  4. $M$410 : 1.11185372875006
  5. $M$410 : 1.11185372875006
  6. $M$410 : 1.11185372875006
  7. $M$410 : 1.11185372875004
  8. $M$410 : 1.11185372875005
  9. $M$410 : 1.11185372875006
  10. $M$410 : 1.11185372875006
  11. $M$410 : 1.11185372875006
  12. $M$410 : 1.11185372875006
  13. $M$410 : 1.11185372875004
  14. $M$410 : 1.11185372875005
  15. $M$410 : 1.11185372875006
  16. $M$410 : 1.11185372875006
  17. $M$410 : 1.11185372875006
  18. $M$410 : 1.11185372875006
  19. $M$410 : 1.11185372875004
  20. $M$410 : 1.11185372875005
  21. $M$410 : 1.11185372875006
複製代碼
作者: 518587    時間: 2014-4-23 18:48

回復 20# GBKEE


謝謝版大，真的很謝謝你的幫忙!!
找出了問題也解決了~
但是有個問題想請問一下，
幫Ln(1)=0的那裏，為什麼還可以算出值?!
想請問一下版大，是做了什麼功能或是計算呢?
作者: GBKEE    時間: 2014-4-23 20:11

回復 21# 518587
Ln(1)=0的那裏，為什麼還可以算出值?!

程式碼開頭有   On Error Resume Next   '程式碼有錯誤時 繼續下一行程式碼(不理會)

接下有註解  '*** 到 A578 時 H578 = 1 Ln(.Cells(1, 6))=0
                '*** 分母=0 不可除 的錯誤  ***************
                '*** 接下的數字會有錯誤    ***************
                '.Cells(1,7) 'I欄 ** 6.ck=(-(Dpk^2)/ln(Ri))       (出現一個數)
                .Cells(1, 7) = -(.Cells(1, 4) ^ 2) / Application.Ln(.Cells(1, 6))



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