joey77373

回復 10# Hsieh

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

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

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

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

其他都沒問題。

Hsieh

回復 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

回復 12# Hsieh



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