Hsieh

回復 20# jj369963
所以並不需要*5/3嗎?

1. Sub Replace_Blank()
   
2. Dim A As Range, Ar(), B As Range
   
3. Set Upw = CreateObject("Scripting.Dictionary") '帳密
   
4. Set dic = CreateObject("Scripting.Dictionary") '參照
   
5. fs = ThisWorkbook.Path & "\replace_rule.txt" 'TEXT檔案位置
   
6. Close #1 '若已經開啟就先關閉
   
7. With Sheets("Sheet0")
   
8. Open fs For Input As #1
   
9. Do Until EOF(1)
   
10.    Line Input #1, mystr
    
11.    If InStr(mystr, ",") > 0 Then
    
12.    s = InStr(mystr, "(")
    
13.    n = InStr(s, mystr, ")")
    
14.    mystr = Mid(mystr, s + 1, n - s - 1)
    
15.    For Each C In Split(mystr, ",")
    
16.      Set A = .Rows(1).Find(C)
    
17.      ReDim Preserve Ar(i)
    
18.      Ar(i) = Split(A.Address, "$")(1)
    
19.      i = i + 1
    
20.    Next
    
21.    For Each p In Ar
    
22.       dic(p) = Ar '記錄公式參照欄位
    
23.    Next
    
24.    Erase Ar: i = 0
    
25.    End If
    
26. Loop
    
27. Close #1
    
28. With Sheets("Sheet1")
    
29.   For Each A In .Range(.[A2], .[A2].End(xlDown))
    
30.      Upw(CStr(A)) = Array(A.Offset(, 3).Value, A.Offset(, 2).Value) '記錄帳密
    
31.   Next
    
32. End With
    
33. '取代複選位置
    
34. Set A = .Range(.[H2], .Cells(.Rows.Count, "CQ").End(xlUp)).Find("*,*")
    
35. If Not A Is Nothing Then
    
36. Do
    
37. ay = Split(A, ",")
    
38. For i = 0 To UBound(ay)
    
39. ReDim Preserve Ar(i)
    
40. Ar(i) = Val(ay(i))
    
41. Next
    
42.   A.Value = Round(Application.Average(Ar), 0)
    
43.   Erase Ar
    
44.   Set A = .Range(.[H2], .Cells(.Rows.Count, "CQ").End(xlUp)).Find("*,*", A)
    
45. Loop Until A Is Nothing
    
46. End If
    
47. i = 0
    
48. .Select
    
49. For Each A In .Range(.[F2], .Cells(.Rows.Count, "F").End(xlUp))
    
50.    A.Offset(, -5).Resize(, 2) = Upw(CStr(A)) '填寫帳密
    
51.    r = A.Row
    
52.    For Each B In .Range(.Cells(r, "H"), .Cells(r, "CQ"))
    
53.       If B = "" Then  '找到空格
    
54.       ay = dic(Split(B.Address, "$")(1))
    
55.       If Not IsEmpty(ay) Then '該儲存格有被公式引用
    
56.          For i = 0 To UBound(ay)
    
57.          If .Range(ay(i) & r) <> "" Then '引用的參照非空白才計入陣列
    
58.            ReDim Preserve Ar(j)
    
59.            Ar(j) = ay(i) & r
    
60.            j = j + 1
    
61.          End If
    
62.          Next
    
63.         If j > 0 Then B.Value = Round(Application.Evaluate("Average(" & Join(Ar, ",") & ")"), 0)
    
64.          Erase Ar
    
65.          j = 0
    
66.       End If
    
67.       End If
    
68.     Next
    
69. Next
    
70. End With
    
71. End Sub

複製代碼

jj369963

回復 21# Hsieh

Dear Hsieh版大：

             真是感謝再感謝，擾您費心了(真是費很多心)。著實覺得感動想在心中呼喊
            works successfully
           如果不介意想再請教一個問題，對不起又給您出題了
          如果想在跑完之後，去檢查 每一列中還有空白的(就是沒有被程式取代)，因為整大題沒寫，缺失值過多，像這樣的資料那一列，以下依難易度，選擇其一處理：
           1.列有空白值，學號標記顏色
           2.列有空白值，將該列排序於最後(就是要複製該列，貼於最後，又刪除原本的列)
           3.列有空白值，將該列剪下，貼至其他sheet
         
            真是大大不好意思，再請指教
          感謝

jj369963

回復 21# Hsieh

Dear Hsieh版大：

   感謝您費心的指導，取代時不需要*5/3

but 昨天半夜發現到一個問題，有反向題，我的天
所以又來請益
就是在 第1題到第48題
原本答案是  1 convert to 3  (1改3)
                         2 convert to 1  (2改1)
                         3 convert to  2 (3改2)
                           複選就清空
    之後依規則取代空值

真是sorry沒有注意到，再煩請指教
謝謝

jj369963

回復 21# Hsieh

Dear Hsieh版大：

  真是sorry，我的腦袋已經混亂了。還造成麻煩真是抱歉，重新思考整個邏輯順序， 應該是這樣：

1.清空複選
2. 在 第1題到第48題
     原本答案是  1 convert to 3  (1改3)
                             2 convert to 1  (2改1)
                             3 convert to  2 (3改2)
3.再依規則取代，不需要*5/3，程式碼執行不需要有CR:DC欄位的公式
4.標記 一大題沒寫的(還有空值)的 學號  

真是抱歉一直打擾，再麻煩您指教
謝謝

jj369963

回復 21# Hsieh


    Dear Hsieh版大：

      又來討教， 真不好意思，目前針對 第1題到第48題 的 轉換
原本答案是  1 convert to 3  (1改3)
                         2 convert to 1  (2改1)
                         3 convert to  2 (3改2)

  想到的是 =IF(H2=1,3,IF(H2=2,1,IF(H2=3,2,""))) 往右往下，但是用公式無法取代原本cell ，不知是否可以用vba?

或是以下語法(不知道vba適用下列語法嗎)

RECODE
  第1題 第2題 第3題 第4題 第5題 第6題 第7題 第8題 第9題 第10題 第11題 第12題 第13題 第14題 第15題 第16題 第17題 第18題 第19題
  第20題 第21題 第22題 第23題 第24題 第25題 第26題 第27題 第28題 第29題 第30題 第31題 第32題 第33題 第34題 第35題 第36題
  第37題 第38題 第39題 第40題 第41題 第42題 第43題 第44題 第45題 第46題 第47題 第48題  (1=3)  (2=1)  (3=2)  .
EXECUTE .

再煩請指教 變數直接在cell轉換的方法

謝謝 &無限感激

Hsieh

回復 25# jj369963

1. With [H:BC] '1~48題的欄位
   
2. .Replace 1, "3@", xlWhole '將1用一個不常用符號取代
   
3. .Replace 2, 1, xlWhole '將2用1取代
   
4. .Replace 3, 2, xlWhole '將3用2取代
   
5. .Replace "3@", 3, xlWhole '將不常用符號用3取代
   
6. End With

複製代碼

jj369963

回復 26# Hsieh


    Dear Hsieh版大：

   謝謝您熱心的回覆，非常感激，原來技巧是『用一個不常用符號取代』，真是妙，感謝。
   另外想再請教一個問題(我怎麼有無數的問題呀，天呀)
    之前看文章 我知道vba可以搜尋關鍵字，並顏色標記整列
   我的意思是
   整個資料全部處理完後，還是有missing(因為無公式可以對應取代)，所以是否可以
   在A-CQ欄 搜尋missing ，並將整列標記顏色(黃色)，舉例如果A15為空值，就將第15列全部標顏色，依此類推
   
   亦或是將還有空值的整列 移到別的sheet,如sheet2 ->這樣的方式不知是否可以用vba??

    再煩請大大，多多指教
   再次感謝

Hsieh

回復 27# jj369963

整個資料全部處理完後，還是有missing(因為無公式可以對應取代)，所以是否可以
   在A-CQ欄 搜尋missing ，並將整列標記顏色(黃色)，舉例如果A15為空值，就將第15列全部標顏色，依此類推

標顏色用格式化條件即可達成
=(COUNTBLANK($A1:$CQ1)>0)*(COUNTA($A1:$CQ1)>0)

下載 (120.19 KB)

2013-10-16 08:33

jj369963

回復 28# Hsieh


   Dear Hsieh大大：
                                    非常感謝您的回覆，原來用點邏輯，並藉由格式劃設定即可做到，感激。
                                     第一次學習VBA，還搞不清狀況的說，真的很感謝您的指導。我稍微修改一下如下語法：
                                但是我想再請問一個問題，因為我的原始檔案是 字串 ，我想改成數值  從D欄到CO欄，我知道可以改 儲存格格式，或手動按鈕轉數值，
                               但還是忍不住想請教一下如何可以用vba把文字轉成數值，如附檔，再請多指教，
                              另外真得很感謝您讓我知道VBA得好玩有趣。

1. Sub Replace_Blank()
   
2. Columns("A:A").Select
   
3.     Selection.Insert Shift:=xlToRight
   
4.     Selection.Insert Shift:=xlToRight
   
5. 
   
6. 
   
7. Range("A1").Select
   
8.     ActiveCell.FormulaR1C1 = "user"
   
9.     Range("B1").Select
   
10.     ActiveCell.FormulaR1C1 = "password"
    
11. 
    
12. 
    
13.     Dim E As Range
    
14.     For Each E In Range("f:f").SpecialCells(xlCellTypeConstants)
    
15.         E.Value = "'" & Replace(E, ",", "")
    
16.     Next
    
17. 
    
18. 
    
19. With [H:BC]
    
20. .Replace "*,*", "", xlWhole '清除複選
    
21. End With
    
22. With [H:BC] '1~48題的欄位
    
23. 
    
24. 
    
25. .Replace 1, "3@", xlWhole '將1用一個不常用符號取代
    
26. 
    
27. 
    
28. .Replace 2, 1, xlWhole '將2用1取代
    
29. 
    
30. 
    
31. .Replace 3, 2, xlWhole '將3用2取代
    
32. 
    
33. 
    
34. .Replace "3@", 3, xlWhole '將不常用符號用3取代
    
35. 
    
36. 
    
37. End With
    
38. Dim A As Range, Ar(), B As Range
    
39. Set Upw = CreateObject("Scripting.Dictionary") '帳密
    
40. Set dic = CreateObject("Scripting.Dictionary") '參照
    
41. fs = ThisWorkbook.Path & "\replace_rule.txt" 'TEXT檔案位置
    
42. Close #1 '若已經開啟就先關閉
    
43. With Sheets("Sheet0")
    
44. Open fs For Input As #1
    
45. Do Until EOF(1)
    
46.    Line Input #1, mystr
    
47.    If InStr(mystr, ",") > 0 Then
    
48.    s = InStr(mystr, "(")
    
49.    n = InStr(s, mystr, ")")
    
50.    mystr = Mid(mystr, s + 1, n - s - 1)
    
51.    For Each C In Split(mystr, ",")
    
52.      Set A = .Rows(1).Find(C)
    
53.      ReDim Preserve Ar(i)
    
54.      Ar(i) = Split(A.Address, "$")(1)
    
55.      i = i + 1
    
56.    Next
    
57.    For Each p In Ar
    
58.       dic(p) = Ar '記錄公式參照欄位
    
59.    Next
    
60.    Erase Ar: i = 0
    
61.    End If
    
62. Loop
    
63. Close #1
    
64. With Sheets("Sheet1")
    
65.   For Each A In .Range(.[A2], .[A2].End(xlDown))
    
66.      Upw(CStr(A)) = Array(A.Offset(, 3).Value, A.Offset(, 2).Value) '記錄帳密
    
67.   Next
    
68. End With
    
69. '取代複選位置
    
70. Set A = .Range(.[H2], .Cells(.Rows.Count, "CQ").End(xlUp)).Find("*,*")
    
71. If Not A Is Nothing Then
    
72. Do
    
73. ay = Split(A, ",")
    
74. For i = 0 To UBound(ay)
    
75. ReDim Preserve Ar(i)
    
76. Ar(i) = Val(ay(i))
    
77. Next
    
78.   A.Value = Round(Application.Average(Ar), 0)
    
79.   Erase Ar
    
80.   Set A = .Range(.[H2], .Cells(.Rows.Count, "CQ").End(xlUp)).Find("*,*", A)
    
81. Loop Until A Is Nothing
    
82. End If
    
83. i = 0
    
84. .Select
    
85. For Each A In .Range(.[F2], .Cells(.Rows.Count, "F").End(xlUp))
    
86.    A.Offset(, -5).Resize(, 2) = Upw(CStr(A)) '填寫帳密
    
87.    r = A.Row
    
88.    For Each B In .Range(.Cells(r, "H"), .Cells(r, "CQ"))
    
89.       If B = "" Then  '找到空格
    
90.       ay = dic(Split(B.Address, "$")(1))
    
91.       If Not IsEmpty(ay) Then '該儲存格有被公式引用
    
92.          For i = 0 To UBound(ay)
    
93.          If .Range(ay(i) & r) <> "" Then '引用的參照非空白才計入陣列
    
94.            ReDim Preserve Ar(j)
    
95.            Ar(j) = ay(i) & r
    
96.            j = j + 1
    
97.          End If
    
98.          Next
    
99.         If j > 0 Then B.Value = Round(Application.Evaluate("Average(" & Join(Ar, ",") & ")"), 0)
    
100.          Erase Ar
     
101.          j = 0
     
102.       End If
     
103.       End If
     
104.     Next
     
105. Next
     
106. End With
     
107. 
     
108. Cells.Select
     
109.     Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
     
110.         "=(COUNTBLANK($A1:$CQ1)>0)*(COUNTA($A1:$CQ1)>0)"
     
111.     Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
     
112.     With Selection.FormatConditions(1).Interior
     
113.         .PatternColorIndex = xlAutomatic
     
114.         .ThemeColor = xlThemeColorAccent6
     
115.         .TintAndShade = 0.399945066682943
     
116.     End With
     
117.     Selection.FormatConditions(1).StopIfTrue = True
     
118. 
     
119. 
     
120. End Sub
     
121. 
     
122. 
     

複製代碼

[attach]16355[/attach]

jj369963

回復 21# Hsieh


    DEAR Hsieh 版大：

          SORRY，又來打擾，套用公式後，會發現其中

            好奇籌劃 = MEAN(第52題,第60題,第64題)
             希望立命 = MEAN(第57題,第65題,第68題)
              安在處境 = MEAN(第56題,第66題,第73題)
               有時並沒有依照公式四捨五入
如檔案(第二列)
第57題=MISSING
第65題=4
第68題)=5
所以第57題=(4+5)/2=4.5=5  但出來的結果是 第57題=4

同理(第二列)
第52題=5
第60題=MISSING
第64題=4

所以第60題=(4+5)/2=4.5=5  但出來的結果是 第60題=4

但語法已有ROUND
If j > 0 Then B.Value = Round(Application.Evaluate("Average(" & Join(Ar, ",") & ")"), 0)

因為找不到round錯誤的原因，所以又來請益，

再煩請多指教，謝謝。

[attach]16459[/attach]