Hsieh

回復 10# jj369963

這檔案的空格實在找不出到底隱藏甚麼看不見的字元，所以若使用Application.Counta函數去算數量會找不到空格
只好每格去檢查
再則資料區域改變，變數亦須改變
把帳密檔案與EXCEL檔放在同一目錄，試試

1. Sub ex()
   
2. Dim Rng As Range, A As Range, C As Range
   
3. Set dic = CreateObject("Scripting.Dictionary")
   
4. fs = ThisWorkbook.Path & "\replace_rule.txt"
   
5. Close #1
   
6. 
   
7. Open fs For Input As #1
   
8. Do Until EOF(1)
   
9.   Line Input #1, mystr
   
10.   If InStr(mystr, "=") > 0 Then
    
11.   n = Application.Match(Trim(Split(mystr, "=")(0)), Rows(1), 0)
    
12.   x = Split(Replace(Replace(Replace(Replace(Split(mystr, "=")(1), "MEAN(", ""), ")", ""), ".", ""), " ", ""), ",")
    
13.   For Each ky In x
    
14.     dic(Trim(ky)) = n
    
15.   Next
    
16.   End If
    
17. Loop
    
18. Close #1
    
19. r = 2
    
20. Do Until Cells(r, 1) = ""
    
21.   Set Rng = Cells(r, 8).Resize(, 88) '因為從H欄開始找空格，所以改為Cells(r, 8)
    
22.   For Each A In Rng
    
23.   If A = "" Then
    
24.   k = A.Column
    
25.   v = Trim(Cells(1, k).Value)
    
26.   s = dic(v)
    
27.   A = Cells(r, s)
    
28.   End If
    
29.   Next
    
30. r = r + 1
    
31. Loop
    
32. End Sub

複製代碼

jj369963

回復 11# Hsieh


    Dear版主大大:

不好意思，不材的我又來求救了，
依您的vba程式 確實有跑出來，感激
但是換到其它一樣的檔案試試，就會顯示 『找不倒檔案的訊息』，如附檔

另外 檔案中 A欄與B欄 有用vlookup找帳 密，如果可以是否可以寫進VBA裡??

萬分感謝

再煩請指教不才的我

[attach]16220[/attach]

jj369963

回復 11# Hsieh


   Dear版主大大:

          您好，忘記說了，是否可以把跑出來的數值再四捨五入(round)變成整數後，再取代mising 值呢?

  
           再麻煩與上述問題  一同指教

感謝

Hsieh

回復 12# jj369963


    找不到檔案的訊息，可能是TXT檔與該EXCEL檔案沒有放在同一個資料夾內
因為我測試時並無此情況發生，只是發現若該空格的參照並未被右側公式所引用時就會出錯
試試以下程式碼看看

1. Sub ex()
   
2. Dim Rng As Range, A As Range, C As Range
   
3. Set dic = CreateObject("Scripting.Dictionary")
   
4. Set dic1 = CreateObject("Scripting.Dictionary")
   
5. 
   
6. fs = ThisWorkbook.Path & "\replace_rule.txt"
   
7. Close #1
   
8. 
   
9. Open fs For Input As #1
   
10. Do Until EOF(1)
    
11.   Line Input #1, mystr
    
12.   If InStr(mystr, "=") > 0 Then
    
13.   n = Application.Match(Trim(Split(mystr, "=")(0)), Rows(1), 0)
    
14.   x = Split(Replace(Replace(Replace(Replace(Split(mystr, "=")(1), "MEAN(", ""), ")", ""), ".", ""), " ", ""), ",")
    
15.   For Each ky In x
    
16.     dic(Trim(ky)) = n
    
17.   Next
    
18.   End If
    
19. Loop
    
20. Close #1
    
21. With Sheet2
    
22. For Each A In .Range(.[A2], .[A2].End(xlDown))
    
23.    dic1(A.Value) = Array(A.Offset(, 2).Value, A.Offset(, 3).Value) '紀錄帳密
    
24. Next
    
25. End With
    
26. r = 2
    
27. With Sheets("Sheet0")
    
28. Do Until .Cells(r, 1) = ""
    
29. .Cells(r, 1).Resize(, 2) = dic1(.Cells(r, 6).Value) '填入帳密
    
30.   Set Rng = .Cells(r, 8).Resize(, 88) '因為從H欄開始找空格，所以改為.Cells(r, 8)
    
31.   For Each A In Rng
    
32.   If A = "" Then
    
33.   k = A.Column
    
34.   v = Trim(.Cells(1, k).Value)
    
35.   s = dic(v)
    
36.   If s <> "" Then A = Round(.Cells(r, s), 0) Else: A = "無引用" '如果空格有被公式參照則填入數值，無則填入"無引用"字串
    
37.   End If
    
38.   Next
    
39. r = r + 1
    
40. Loop
    
41. End With
    
42. End Sub

複製代碼

jj369963

回復 14# Hsieh

    Dear版主大大:
                 謝謝大大的回應，非常感謝，用了上述公式用在同ㄧ檔案成功了。真是amazing感謝。
             但是ㄧ波未平一波又起，用再另一個檔案卻又出現問題了，如附檔。所以又厚臉皮來求救了，  真是的我><

       另外，因為類似的檔案有近百個，其中 有重複做答，所以困難度加深了
         1.  需先處理 cell裡重複作答的數字部份，英文不用
              cell裡的數字，如果複選會用逗點隔開，如(1,2,3,4,5) 是否可以先把複選的cell平均後(1+2+3+4+5)，並round四捨五入填入，不知這樣可行嗎?

         2.之後再找missing value ，直接依 replace_rule.txt 公式做取代
             另外如果可以是否可以不要參照excel的CR 到DC欄， 直接依 replace_rule.txt
            因為其實　R　I　Ａ　S　Ｅ　C　是還要乘以5/3，也就是(excel上)
             R = MEAN(第4題,第6題,第19題,第24題,第27題,第39題,第43題,第47題) *5/3
             I = MEAN(第5題,第7題,第15題,第20題,第22題,第29題,第35題,第40題) *5/3
             A = MEAN(第2題,第9題,第12題,第18題,第23題,第28題,第32題,第36題) *5/3
             S = MEAN(第3題,第11題,第25題,第30題,第33題,第37題,第41題,第45題) *5/3
             E = MEAN(第8題,第13題,第16題,第21題,第31題,第38題,第42題,第48題) *5/3
             C = MEAN(第1題,第10題,第14題,第17題,第26題,第34題,第44題,第46題) *5/3

           但是因為要對應  取代missing value 是沒有乘以5/3，也就是
             R = MEAN(第4題,第6題,第19題,第24題,第27題,第39題,第43題,第47題)
             I = MEAN(第5題,第7題,第15題,第20題,第22題,第29題,第35題,第40題)
             A = MEAN(第2題,第9題,第12題,第18題,第23題,第28題,第32題,第36題)
             S = MEAN(第3題,第11題,第25題,第30題,第33題,第37題,第41題,第45題)
             E = MEAN(第8題,第13題,第16題,第21題,第31題,第38題,第42題,第48題)
             C = MEAN(第1題,第10題,第14題,第17題,第26題,第34題,第44題,第46題)
              所以如果可以是否可以不要參照excel的CR 到DC欄， 直接依 replace_rule.txt ，不知這樣可行嗎?

          3.最後帳密的部份，請問是否可以直接 把vlookup公式寫入(不再貼公式)，也就是在sheet1放帳密資訊，對照到
            sheet0的user與 password欄位，最後再進行錄製，不知這樣可行嗎?

            其實問題還蠻難的，所以想問可行度，當然如果不行，也希望多給建議(越來越覺得自己太厚臉皮了)
            最後感謝版主大大每次都超級期待您的回信，深深感激
         
           最後再麻煩回應指教，感謝
                                               [attach]16232[/attach]

jj369963

回復 14# Hsieh

Dear版主大大:
      不好意思，又來叨擾。
     根據上一篇的
     1.  需先處理 cell裡重複作答的數字部份，英文不用
              cell裡的數字，如果複選會用逗點隔開，如(1,2,3,4,5) 是否可以先把複選的cell平均後(1+2+3+4+5)，並round四捨五入填入，
           因為我覺得太困難了，改成  把複選作答清空當成missing值，這樣是否比較簡單?? 如果vba無法複選平均，那是否可以清空複選當missing


      2.  之後再找missing value ，直接依 replace_rule.txt 公式做取代
             另外如果可以是否可以不要參照excel的CR 到DC欄， 直接依 replace_rule.txt ???
              回覆:但是如果VBA無法直接參照replace_rule.txt，就是還是需要參照excel的CR 到DC欄，那就依原本的

        3.最後帳密的部份，請問是否可以直接 把vlookup公式寫入(不再貼公式)，也就是在sheet1放帳密資訊，對照到
            sheet0的user與 password欄位，最後再進行錄製，不知這樣可行嗎?
         
                回覆:  把vlookup公式寫入(不再貼公式)，也就是在sheet1放帳密資訊，對照到
            sheet0的user與 password欄位，這部份不需要，依原本的錄製帳密即可

                    主要是針對 第1點 的複選處理，希望大大予以協助或建議
                   真是抱歉百忙叨擾，再請多指教
                           萬分感謝

Hsieh

回復 16# jj369963

試試看

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 Sheet1
   
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 工作表1
    
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) = CInt(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.            ReDim Preserve Ar(i)
    
58.            Ar(i) = ay(i) & r
    
59.          Next
    
60.         If Application.Count(.Range(Join(Ar, ","))) > 0 Then B.Value = Round(Application.Evaluate("Average(" & Join(Ar, ",") & ")*5/3"), 0)
    
61.          Erase Ar
    
62.       End If
    
63.       End If
    
64.     Next
    
65. Next
    
66. End With
    
67. End Sub

複製代碼

jj369963

回復 17# Hsieh

Dear  Hsieh 版大：

  太感激您的回覆，淚奔，也多謝您的費心

but 又要勞煩您看一下，run的時候出現錯誤了

跳出的錯誤視窗如附檔

我知道如果cell有  #N/A ，再跑vba好像都會有錯誤視窗跳出

目前已把會出現  #N/A 設為空白，但是 跑vba還是又出錯了

另外 　 套入取代missing 的 R　I　Ａ　S　Ｅ　C是不要*5/3但四捨五入，
                  而CR欄到CW欄 的  R　I　Ａ　S　Ｅ　C　是要乘以5/3

不過最主要的還是把複數題 變成missing值 ，再依規則取代

三番兩次打擾真是不好意思

再麻煩您指教了

謝謝

[attach]16267[/attach]

Hsieh

回復 18# jj369963

不懂你所說

另外 　 套入取代missing 的 R　I　Ａ　S　Ｅ　C是不要*5/3但四捨五入，
                  而CR欄到CW欄 的  R　I　Ａ　S　Ｅ　C　是要乘以5/3

  程式碼執行已經不需要有CR:DC欄位的公式，你驗算看看差異在哪?

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.            ReDim Preserve Ar(i)
    
58.            Ar(i) = ay(i) & r
    
59.          Next
    
60.         If Application.Count(.Range(Join(Ar, ","))) > 0 Then B.Value = Round(Application.Evaluate("Average(" & Join(Ar, ",") & ")*5/3"), 0)
    
61.          Erase Ar
    
62.       End If
    
63.       End If
    
64.     Next
    
65. Next
    
66. End With
    
67. End Sub

複製代碼

jj369963

回復 19# Hsieh


    Dear  Hsieh 版大：

    感謝您的回覆，it works非常的感動.  我測試後，程式碼執行確實已經不需要有CR:DC欄位的公式。

    but 計算的結果有點小問題  第1題 到 第48題 只能是1或2或3          所以平均出來不可能是4或5 (但是現在run的結果卻跑出4或5)

規則是：   
MEAN(第4題,第6題,第19題,第24題,第27題,第39題,第43題,第47題)
MEAN(第5題,第7題,第15題,第20題,第22題,第29題,第35題,第40題)
MEAN(第2題,第9題,第12題,第18題,第23題,第28題,第32題,第36題)
MEAN(第3題,第11題,第25題,第30題,第33題,第37題,第41題,第45題)
MEAN(第8題,第13題,第16題,第21題,第31題,第38題,第42題,第48題)
MEAN(第1題,第10題,第14題,第17題,第26題,第34題,第44題,第46題)
MEAN(第74題,第76題,第78題,第80題,第82題)
MEAN(第75題,第77題,第79題,第81題,第83題)
MEAN(第84題,第85題,第86題,第87題,第88題)
MEAN(第52題,第60題,第64題)
MEAN(第57題,第65題,第68題)
MEAN(第56題,第66題,第73題)

也就是 第4題missing 就平均 第6題,第19題,第24題,第27題,第39題,第43題,第47題，取四捨五入
              第6題,第19題 missing 就平均第4題,第24題,第27題,第39題,第43題,第47題，取四捨五入

就是一組裡，如果有missing值就平均其他值，再取代

目前我測試 第1題 missing  
                      第10題=2
                       第14題=2
                       第17題=2
                        第26題=1
                       第34題=1
                        第44題 =2
                        第46題=2
所以第一題=round(average(2,2,2,1,1,2,2)=1.714285714=2

但是執行vba跑出來是  第一題= 3

現在跑出來第1題H2=3， 第20題 AA10=4 ，  第30題AK27=5

所以計算結果數值是有問題的

可以再麻煩您看一下嗎?  真是抱歉一直打擾，再麻煩您指教
謝謝

附註：您之前的回覆『回復 12』，計算出來的結果是對的

[attach]16273[/attach]