[發問] 請問有msgbox用&quot;物件查詢&quot;巨集能幫小弟解決問題嗎?

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

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

2^#

發表於 2013-6-3 23:42 | 只看該作者

回復 1# joey77373
你舉例的答案似乎與檔案內容不符
第一題若是以20%為基準應該只有C、E

第二題是要找出L:Q的最大值嗎?那應該是C元件的致癌性%數

Public Rng As Range
Sub 第一題()
Dim myInput, i As Integer, Ar As Variant, MyMax#, MyStr
Dim Str As String, Dic As Object
myInput = InputBox("請輸入總汙染門檻值(%):")
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To 9
If Not IsNumeric(Cells(i, 9)) Then MsgBox "I" & i & "請輸入數字": Exit Sub
If Cells(i, 9) >= (myInput / 1) Then
Dic(Cells(i, 1).Value) = Array(Cells(i, 9), Cells(i, 1))
If Rng Is Nothing Then Set Rng = Cells(i, "L").Resize(, 6) Else Set Rng = Union(Rng, Cells(i, "L").Resize(, 6))
End If
Next i
If Dic.Count = 0 Then MsgBox "沒有符合條件的元件": Set Rng = Nothing: Exit Sub
TestStr = Join(Dic.keys, ",")
Do Until Dic.Count = 0
Ar = Application.Transpose(Application.Transpose(Dic.items))
MyMax = Application.Max(Application.Index(Ar, , 1))
MyStr = Application.VLookup(MyMax, Ar, 2, 0)
MsgBox "元件 " & MyStr & " " & MyMax
Dic.Remove MyStr
Loop
End Sub

複製代碼

Sub 第二題()
Dim MyMax#, MyStr$, MyTital$
If Rng Is Nothing Then MsgBox "未有符合之元件，請先執行第一題": Exit Sub
If Application.Count(Rng) <> Rng.Count Then MsgBox Rng.SpecialCells(xlCellTypeConstants, 2).Address & "為非數值資料": Exit Sub
MyMax = Application.Max(Rng)
MyStr = Cells(Rng.Find(MyMax, lookat:=xlWhole).Row, "A")
MyTital = Cells(1, Rng.Find(MyMax, lookat:=xlWhole).Column)
MsgBox "元件 " & MyStr & MyTital & " " & Format(MyMax, "0.00%")
End Sub

複製代碼

第三題就看不出與第一、二題有何關聯性，請詳細說明之

學海無涯_不恥下問

帖子: 8
主題: 1
精華: 0
積分: 18
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: 台灣-桃園
註冊時間: 2013-6-3
最後登錄: 2013-6-9

3^#

發表於 2013-6-4 00:54 | 只看該作者

首先，感謝Hsieh為小弟抽空相助，抱歉表達得不夠詳細，在下面補充說明！

第一題的部分因為excel稍做修正，word檔忘記更變答案，抱歉。

第二題的部分說明A至H元件在各汙染環境的影響%數，題目中所述之詢問
若使用者想找元件A至H"溫室效應"影響最嚴重的元件，則VBA給出的答案為"C元件"
若使用者想找元件A至H"重金屬"影響最嚴重的元件，則VBA給出的答案為"E元件"

第三題承接第二題，假如使用者在第二題詢問"溫室效應"影響最嚴重的元件
答案給出"C元件"
從第二題可以知道C元件是該產品元件中對"溫室效應"帶來的影響最大
所以使用者會去尋找可以替代"C元件"的元件，這也是第三題的論述
使用者從原先"C元件"與可以用來替代C元件的"元件C-1"、"元件C-2"
因為這些替代元件在"溫室效應"都比原先的低，所以使用者在第三題會比較這三個元件
對"整個環境汙染總權重值(也就是Z欄位的值)"，尋找車Z欄位值最低的元件為C-2
代表元件C-2是可以用來替代原先C元件的替代性元件。

不知道這樣敘述有沒有比較清楚，感謝花費時間幫忙。

帖子: 8
主題: 1
精華: 0
積分: 18
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: 台灣-桃園
註冊時間: 2013-6-3
最後登錄: 2013-6-9

4^#

發表於 2013-6-4 01:11 | 只看該作者

回復 2# Hsieh
剛剛忘了用回復功能

提供的範例問題與Excel很好看出答案，因為真實數據上百筆關係到案例公司機密
所以只能用部分數據在此詢問感謝能提供指令讓小弟能順利執行。

帖子: 8
主題: 1
精華: 0
積分: 18
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: 台灣-桃園
註冊時間: 2013-6-3
最後登錄: 2013-6-9

5^#

發表於 2013-6-4 13:58 | 只看該作者

回復 2# Hsieh

我補充一下，因為前面的描述我給有程式底子的朋友他們說看不懂
要我修改方式去描述
這樣講應該比較清楚

第二題想呈現的結果
延伸第一題的結果，比較L到Q各欄位的大小，例如：此時我輸入關注L欄位
則會去比較元件C的L欄位，跟元件E的L欄位之間大小，顯示出大的數值

第三題想呈現的結果
比較Z欄位的大小，選擇最小的

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

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

6^#

發表於 2013-6-4 15:13 | 只看該作者

回復 5# joey77373

Public Rng As Range
Sub 第一題()
Dim myInput, i As Integer, Ar As Variant, MyMax#, MyStr
Dim Str As String, Dic As Object
myInput = InputBox("請輸入總汙染門檻值(%):")
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To 9
If Not IsNumeric(Cells(i, 9)) Then MsgBox "I" & i & "請輸入數字": Exit Sub
If Cells(i, 9) >= (myInput / 1) Then
Dic(Cells(i, 1).Value) = Array(Cells(i, 9), Cells(i, 1))
If Rng Is Nothing Then Set Rng = Cells(i, "L").Resize(, 6) Else Set Rng = Union(Rng, Cells(i, "L").Resize(, 6))
End If
Next i
If Dic.Count = 0 Then MsgBox "沒有符合條件的元件": Set Rng = Nothing: Exit Sub
TestStr = Join(Dic.keys, ",")
Do Until Dic.Count = 0
Ar = Application.Transpose(Application.Transpose(Dic.items))
MyMax = Application.Max(Application.Index(Ar, , 1))
MyStr = Application.VLookup(MyMax, Ar, 2, 0)
MsgBox "元件 " & MyStr & " " & MyMax
Dic.Remove MyStr
Loop
End Sub
Sub 第二題()
Dim MyMax#, MyStr$, MyTital$, MyCol%, Rw As Range
If Rng Is Nothing Then MsgBox "未有符合之元件，請先執行第一題": Exit Sub
If Application.Count(Rng) <> Rng.Count Then MsgBox Rng.SpecialCells(xlCellTypeConstants, 2).Address & "為非數值資料": Exit Sub
MyCol = InputBox("溫室效應%數=1" & Chr(10) & "臭氧消耗%數=2" & Chr(10) & "酸化%數=3" & Chr(10) & "優養化%數=4" & Chr(10) & "重金屬%數=5" & Chr(10) & "致癌性%數=6", "請輸入欄位", 1)
For Each Rw In Rng.Rows
If Rw.Cells(MyCol) > MyMax Then MyMax = Rw.Cells(MyCol): MyStr = Cells(Rw.Row, 1)
Next
MsgBox "元件 " & MyStr & " " & Format(MyMax, "0.00%")
End Sub
Sub 第三題()
Dim MyMax#, MyStr$, MyTital$, MyCol%
If Application.Count([Z2:Z4]) <> [Z2:Z4].Count Then MsgBox [Z2:Z4].SpecialCells(xlCellTypeConstants, 2).Address & "為非數值資料": Exit Sub
MyMax = Application.Min([Z2:Z4])
k = Application.Match(MyMax, [Z2:Z4], 0)
MsgBox "元件 " & [S1].Offset(k) & " 總汙染權重值 " & MyMax
End Sub

複製代碼

學海無涯_不恥下問

帖子: 8
主題: 1
精華: 0
積分: 18
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: 台灣-桃園
註冊時間: 2013-6-3
最後登錄: 2013-6-9

7^#

發表於 2013-6-4 16:19 | 只看該作者

回復 6# Hsieh

感謝Hsieh提供，剛剛輸入於Excel中run後，系統直接出現元件C-2總汙染權重值32.62

過程詢問視窗沒有出現，不知道是不是第二題部分的問題。

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

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

8^#

發表於 2013-6-4 18:16 | 只看該作者

回復 7# joey77373
前兩個問題是否有達到你的需求?
第三個問題仍然看不出與前兩個問題的關聯性
是直接取得最小值秀出，與前面的篩選無關
若你的需求並不是如此，請詳述其與前兩個問題的關聯性

學海無涯_不恥下問

帖子: 8
主題: 1
精華: 0
積分: 18
點名: 0
作業系統: Windows 7
軟體版本: Office 2010
閱讀權限: 10
性別: 男
來自: 台灣-桃園
註冊時間: 2013-6-3
最後登錄: 2013-6-9

9^#

發表於 2013-6-4 20:31 | 只看該作者

本帖最後由 joey77373 於 2013-6-4 20:32 編輯

回復 8# Hsieh

抱歉Hsieh大，應該是我描述的問題，我第三個問題的表格變動了一下這樣比較好描述我的問題

與第二題的關聯性是，當結果顯示"C元件"溫室效應%數最高"

所以從第三題的元件資料中尋找"C"的替代元件(S欄位)，從資料可以看到C有4個替代元件(C-1、C-2、C-3、C-4)

然後先比較替代元件的"溫室效應"(T欄位)的值有沒有比原本的高，高的排出(C-3、C-4)

剩下的替代元件(C-1、C-2)，尋找"總汙染權重值"(Z欄位)比較C-1與C-2選擇較小的值為答案。

範例資料.rar (12.18 KB)

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

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

10^#

發表於 2013-6-4 22:47 | 只看該作者

回復 9# joey77373
是這樣嗎?

Public Rng As Range, MyMaxNum#, MyCol%, MyStr$
Sub 第一題()
Dim myInput, i As Integer, Ar As Variant, MyMax# ', MyStr
Dim Str As String, Dic As Object
myInput = InputBox("請輸入總汙染門檻值(%):")
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To 9
If Not IsNumeric(Cells(i, 9)) Then MsgBox "I" & i & "請輸入數字": Exit Sub
If Cells(i, 9) >= (myInput / 1) Then
Dic(Cells(i, 1).Value) = Array(Cells(i, 9), Cells(i, 1))
If Rng Is Nothing Then Set Rng = Cells(i, "L").Resize(, 6) Else Set Rng = Union(Rng, Cells(i, "L").Resize(, 6))
End If
Next i
If Dic.Count = 0 Then MsgBox "沒有符合條件的元件": Set Rng = Nothing: Exit Sub
TestStr = Join(Dic.keys, ",")
Do Until Dic.Count = 0
Ar = Application.Transpose(Application.Transpose(Dic.items))
MyMax = Application.Max(Application.Index(Ar, , 1))
MyStr = Application.VLookup(MyMax, Ar, 2, 0)
MsgBox "元件 " & MyStr & " " & MyMax
Dic.Remove MyStr
Loop
End Sub
Sub 第二題()
Dim MyTital$, Rw As Range
If Rng Is Nothing Then MsgBox "未有符合之元件，請先執行第一題": Exit Sub
If Application.Count(Rng) <> Rng.Count Then MsgBox Rng.SpecialCells(xlCellTypeConstants, 2).Address & "為非數值資料": Exit Sub
MyCol = InputBox("溫室效應%數=1" & Chr(10) & "臭氧消耗%數=2" & Chr(10) & "酸化%數=3" & Chr(10) & "優養化%數=4" & Chr(10) & "重金屬%數=5" & Chr(10) & "致癌性%數=6", "請輸入欄位", 1)
For Each Rw In Rng.Rows
If Rw.Cells(MyCol) > MyMaxNum Then MyMaxNum = Rw.Cells(MyCol): MyStr = Cells(Rw.Row, 1)
Next
MsgBox "元件 " & MyStr & " " & Format(MyMaxNum, "0.00%")
End Sub
Sub 第三題()
Dim A As Range, Temp#
Set A = [S:S].Find(MyStr, lookat:=xlWhole)
Temp = A.Offset(, 7)
Do Until Left(A, 1) <> MyStr
If A.Offset(, MyCol) <= MyMaxNum Then
If A.Offset(, 7) <= Temp Then Temp = A.Offset(, 7): Ch = A: Test = A.Offset(, MyCol)
End If
Set A = A.Offset(1)
Loop
MsgBox "替代元件 " & Ch & [S1].Offset(, MyCol) & "值= " & Test & "總汙染權重值= " & Temp
End Sub

複製代碼

學海無涯_不恥下問