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

joey77373

小弟目前正在編寫研究論文，目前就差最後一步驟論文就完成了。

教授要我在案例部分資料匯入excel，並使用內建vba寫的巨集補在最後一章，讓整個案例好看些

不過教授知道這不是我們專長領域，同意我詢問會vba的人協助

若版上有高手能幫助，小弟真是在感謝不過。

附件中小弟提問了3個指令的問題，第1題小弟有寫了一下但是跑出的答案無法從大致小排列，似乎少了些指令。


※附件中有2個檔案一個為word檔，裡面描述詢問問題，另一個檔案為excel例子資料，還有小弟電子信箱
   主要詢問關於"msgbox"巨集，與問題巨集設定給予範例指令參考，請過目。

Hsieh

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

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

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

複製代碼

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

複製代碼

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

joey77373

首先，感謝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元件的替代性元件。

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

joey77373

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

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

joey77373

回復 2# Hsieh

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

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

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

Hsieh

回復 5# joey77373

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

複製代碼

joey77373

回復 6# Hsieh


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

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

Hsieh

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

joey77373

回復 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選擇較小的值為答案。

Hsieh

回復 9# joey77373
是這樣嗎?

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

複製代碼