an13755

帖子: 20
主題: 7
精華: 0
積分: 50
點名: 0
作業系統: xp
軟體版本: 2003
閱讀權限: 20
性別: 女
註冊時間: 2010-7-16
最後登錄: 2022-5-27

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2010-7-21 20:51 | 只看該作者

兩段條件式總和篩選(小女子跪求程式!!)

各位大師小女子有一實驗表格如附件

item.rar (7.07 KB)

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

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

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

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

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

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

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

故請各位大師幫忙,拜託,謝謝!!

樓主熱帖

an

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 277
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-12-23

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

2^#

發表於 2010-7-21 22:03 | 只看該作者

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

回復 1# an13755

你目前B表的數據是完整的嗎?
依我的理解你先看看

Sub nn()
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheet36
For k = 2 To 9
For r = 2 To .Cells(65536, k).End(xlUp).Row
d(.Cells(r, k).Value) = d(.Cells(r, k).Value) + .Cells(r, 10)
If d(.Cells(r, k).Value) < 20 Then d1(.Cells(r, k).Value) = .Cells(r, "K")
Next
ar = d.keys
ReDim ay(d1.Count)
For i = 1 To d1.Count
n = Application.Small(ar, i)
ay(i - 1) = d1(n)
Next
With Sheet1
.Columns(k + 8) = ""
.Cells(1, k + 8).Resize(d1.Count, 1) = Application.Transpose(ay)
End With
d.RemoveAll
d1.RemoveAll
Next
End With
End Sub

複製代碼

執行後答案在J:Q欄你比較看看差異在哪?

學海無涯_不恥下問

TOP

luhpro

高中生 Rank: 3 Rank: 3

帖子: 835
主題: 6
精華: 0
積分: 915
點名: 16
作業系統: Win 10,7
軟體版本: 2019,2013,2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-3
最後登錄: 2024-11-14

3^#

發表於 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

樓主可以參考看看...

TOP

an13755

中學生 Rank: 2

帖子: 20
主題: 7
精華: 0
積分: 50
點名: 0
作業系統: xp
軟體版本: 2003
閱讀權限: 20
性別: 女
註冊時間: 2010-7-16
最後登錄: 2022-5-27

4^#

發表於 2010-7-21 23:15 | 只看該作者

多謝兩位大師的幫忙

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

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

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

是因為用2003的關係嗎?anyway再次感謝!!

an

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 277
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-12-23

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

5^#

發表於 2010-7-21 23:33 | 只看該作者

回復 4# an13755

06行會出錯?不會吧
原來是要這樣的結果,我會錯意了

Sub nn()
Dim Ar()
Application.ScreenUpdating = False
With Sheet36
For k = 2 To 9
s = 0: r = 2
.Cells(1, k).CurrentRegion.Sort key1:=.Cells(1, k), Header:=xlYes
cnt = .Cells(r, "J")
While cnt < 20
ReDim Preserve Ar(s)
Ar(s) = .Cells(r, "K")
s = s + 1: r = r + 1
cnt = cnt + .Cells(r, "J")
Wend
With Sheet1
.Columns(k + 8) = ""
.Cells(1, k + 8).Resize(s, 1) = Application.Transpose(Ar)
End With
Erase Ar
Next
.[A1].CurrentRegion.Sort key1:=.[A1], Header:=xlYes
End With
Application.ScreenUpdating = True
End Sub

複製代碼

學海無涯_不恥下問

TOP