Board logo

標題: 兩段條件式總和篩選(小女子跪求程式!!) [打印本頁]
作者: an13755    時間: 2010-7-21 20:51     標題: 兩段條件式總和篩選(小女子跪求程式!!)

各位大師小女子有一實驗表格如附件[attach]1920[/attach]

A工作表想要篩選的條件為以下

條件1:b欄(名稱:係數A)由小到大排序(遞增排序)

條件2:j欄(名稱:藥劑量)由上而下累加小於20

取得相對應的編號(k欄)複製貼在B工作表a欄上

以此類推係數B到係數T,共要取得8欄編號貼在B工作表上

附件B工作表小女子已經以人工判斷做好大家可參考

因係數及藥劑量每次實驗數據不同,人工判斷偶有誤差

故請各位大師幫忙,拜託,謝謝!!
作者: Hsieh    時間: 2010-7-21 22:03

本帖最後由 Hsieh 於 2010-7-21 23:22 編輯

回復 1# an13755


    你目前B表的數據是完整的嗎?
依我的理解你先看看
  1. Sub nn()
  2. Set d = CreateObject("Scripting.Dictionary")
  3. Set d1 = CreateObject("Scripting.Dictionary")
  4. With Sheet36
  5.   For k = 2 To 9
  6.      For r = 2 To .Cells(65536, k).End(xlUp).Row
  7.         d(.Cells(r, k).Value) = d(.Cells(r, k).Value) + .Cells(r, 10)
  8.         If d(.Cells(r, k).Value) < 20 Then d1(.Cells(r, k).Value) = .Cells(r, "K")
  9.      Next
  10.      ar = d.keys
  11.      ReDim ay(d1.Count)
  12.      For i = 1 To d1.Count
  13.        n = Application.Small(ar, i)
  14.        ay(i - 1) = d1(n)
  15.      Next
  16. With Sheet1
  17. .Columns(k + 8) = ""
  18. .Cells(1, k + 8).Resize(d1.Count, 1) = Application.Transpose(ay)
  19. End With
  20.   d.RemoveAll
  21.   d1.RemoveAll
  22.   Next
  23. End With
  24. End Sub
複製代碼
執行後答案在J:Q欄你比較看看差異在哪?
作者: luhpro    時間: 2010-7-21 22:09

我的程式執行結果跟一樓的比較接近,唯一的差別在 B14 與 B15 兩個數字相對調.

Sub Macro1()
  Dim Counter As Integer, i As Integer, num As Integer
'
  For Counter = 2 To 9
    Worksheets("a").Cells(1, Counter).Sort _
    Key1:=Worksheets("a").Cells(, Counter), _
    Header:=xlGuess

    i = 2
    num = Worksheets("a").Cells(2, 10)

    While num < 20
      Worksheets("b").Cells(i - 1, Counter - 1) = Worksheets("a").Cells(i, 11)
      i = i + 1
      num = num + Worksheets("a").Cells(i, 10)
    Wend
  Next Counter
End Sub

樓主可以參考看看...
作者: an13755    時間: 2010-7-21 23:15

多謝兩位大師的幫忙

l大的程式完全解決小女子的問題

讓我又學嘞一些東西謝謝!!

h大的程式跑到06行出現錯誤

是因為用2003的關係嗎?anyway再次感謝!!
作者: Hsieh    時間: 2010-7-21 23:33

回復 4# an13755


    06行會出錯?不會吧
原來是要這樣的結果,我會錯意了
  1. Sub nn()
  2. Dim Ar()
  3. Application.ScreenUpdating = False
  4. With Sheet36
  5.   For k = 2 To 9
  6.    s = 0: r = 2
  7.   .Cells(1, k).CurrentRegion.Sort key1:=.Cells(1, k), Header:=xlYes
  8.   cnt = .Cells(r, "J")
  9. While cnt < 20
  10.   ReDim Preserve Ar(s)
  11.   Ar(s) = .Cells(r, "K")
  12.   s = s + 1: r = r + 1
  13.   cnt = cnt + .Cells(r, "J")
  14. Wend
  15. With Sheet1
  16. .Columns(k + 8) = ""
  17. .Cells(1, k + 8).Resize(s, 1) = Application.Transpose(Ar)
  18. End With
  19. Erase Ar
  20.   Next
  21. .[A1].CurrentRegion.Sort key1:=.[A1], Header:=xlYes
  22. End With
  23. Application.ScreenUpdating = True
  24. End Sub
複製代碼




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