Board logo

標題: [發問] 請問有msgbox用"物件查詢"巨集能幫小弟解決問題嗎? [打印本頁]
作者: joey77373    時間: 2013-6-3 20:48     標題: 請問有msgbox用"物件查詢"巨集能幫小弟解決問題嗎?

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

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

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

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

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


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

回復 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    時間: 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元件的替代性元件。

不知道這樣敘述有沒有比較清楚，感謝花費時間幫忙。
作者: joey77373    時間: 2013-6-4 01:11

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

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

回復 2# Hsieh

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

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

第三題想呈現的結果
比較Z欄位的大小，選擇最小的
作者: Hsieh    時間: 2013-6-4 15:13

回復 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    時間: 2013-6-4 16:19

回復 6# Hsieh


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

過程詢問視窗沒有出現，不知道是不是第二題部分的問題。
作者: Hsieh    時間: 2013-6-4 18:16

回復 7# joey77373
前兩個問題是否有達到你的需求?
第三個問題仍然看不出與前兩個問題的關聯性
是直接取得最小值秀出，與前面的篩選無關
若你的需求並不是如此，請詳述其與前兩個問題的關聯性
作者: joey77373    時間: 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選擇較小的值為答案。
作者: Hsieh    時間: 2013-6-4 22:47

回復 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
複製代碼
作者: joey77373    時間: 2013-6-4 23:18

回復 10# Hsieh

對!!是這樣的!!太厲害了(膜拜)

小弟會把Hsieh大在寫論文致謝上感謝幫助！

剛剛試跑，有個小問題，第二題各別針對1至6(溫室效應%數=1、臭氧消耗%數=2、酸化%數=3、優養化%數=4、重金屬%數=5、致癌性%數=6)

跑完後，執行第三題
在第二題觸發1以後進入第三題出現的答案是錯的，其他2至6都正常。

其他都沒問題。
作者: Hsieh    時間: 2013-6-4 23:40

回復 11# joey77373
  1. Public Rng As Range, MyCol%, MyStr$
  2. Sub 第一題()
  3.     Dim myInput, i As Integer, Ar As Variant
  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 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 & [K1].Offset(, MyCol) & 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) <= [A:A].Find(MyStr, lookat:=xlWhole).Offset(, MyCol) 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
複製代碼
作者: joey77373    時間: 2013-6-4 23:51

回復 12# Hsieh



這有了幾個巨集讓我能繼續完成論文未完成部分。
謝謝Hsieh大，這麼費時幫助我，太感謝你了，真的由衷感謝。



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