返回列表 上一主題 發帖

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

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

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

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

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

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

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


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

關於Excel VBA請教.rar (17.84 KB)

關於Excel VBA請教

回復 12# Hsieh



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

TOP

回復 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
複製代碼
學海無涯_不恥下問

TOP

回復 10# Hsieh

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

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

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

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

其他都沒問題。

TOP

回復 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
複製代碼
學海無涯_不恥下問

TOP

本帖最後由 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)

TOP

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

TOP

回復 6# Hsieh


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

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

TOP

回復 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
複製代碼
學海無涯_不恥下問

TOP

回復 2# Hsieh

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

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

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

TOP

        靜思自在 : 心中常存善解、包容、感思、知足、惜福。
返回列表 上一主題