c_c_lai

回復 10# GBKEE
這一招也早就試過了，無效！
我觀察過是 D.KEYS 帶值轉入時的存值問題。
亦即發生在 For Each E In D.KEYS 的之前。
目前怎麼測也都找不出，蠻靈異的。

GBKEE

回復 11# c_c_lai
謝謝你,你已儘全力,莫可耐何它了

Hsieh

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. With 工作表1
   
4.    For Each a In .Range(.[A1], .[A1].End(xlDown))
   
5.       mystr = a & a.Offset(, 1) & a.Offset(, 2) & a.Offset(, 4)
   
6.       If d.exists(mystr) Then MsgBox a & "資料重複"
   
7.       d(mystr) = Application.Transpose(Application.Transpose(a.Resize(, 6).Value))
   
8.    Next
   
9. End With
   
10. With 工作表2
    
11. .Cells.ClearContents
    
12. .[A1].Resize(d.Count, 6) = Application.Transpose(Application.Transpose(d.items))
    
13. End With
    
14. End Sub

複製代碼

回復 5# jackyliu

jackyliu

版大 :
一樣是 執行階段錯誤'13'型態不符
時可以有時有錯誤,是不接受這樣的寫法嗎?
不知道是哪出了問題 ?

GBKEE

回復 14# jackyliu
Hsieh超版 13# 的試了,沒如沒錯誤可照著改試試看

jackyliu

版大:
       程式碼換上最後版, 一樣會出現 ---> 執行階段錯誤'13' 型態不符
程式偵錯停滯在 更新的那段, 看不出來是什麼問題, 版大可以幫忙一下嗎?

     .Cells(I, "A").Resize(1, UBound(D(K), 2)) = D(K)

GBKEE

回復 16# jackyliu
我只有2003版執行一直好好的, 無法查出你的錯誤在哪裡.
c_c_lai 也幫忙測試其他版本有時會有錯誤.(不了解為何如此)

c_c_lai

回復 16# jackyliu
這是經過我測試過 OK 的，雖然內容大致一樣，
但還是使用我的程式碼試試看。
(之前我亦測出你所說的狀況，試試這隻看看，其中也將 Debug 的過程內容亦併作成註釋)

1. Option Explicit
   
2. 
   
3. Sub Ex()
   
4.     Dim Dk As Object, E As Variant, cts As Integer
   
5.     '  Dim Dk As Object, E, cts As Integer
   
6.    
   
7.     Set Dk = CreateObject("Scripting.dictionary")         '  字典物件
   
8.    
   
9.     '  1. 將 Sheet1 的資料,複製到 Sheet2 的 A1 位置開始,依序寫入.
   
10.     '  2. 重複性的資料,不要再重複複製到Sheet2
    
11.     '  3. 比較不可重複欄位:姓名,地區,性別,婚姻
    
12.     For Each E In Sheet1.Range("A1").CurrentRegion.Rows  '  物件: A1 所延伸範圍的列
    
13.         '  E.Value : Variant/Variant(1 to 1, 1 to 6) : ThisWorkbook.Ex
    
14.         '  E.Value(1,1) : "姓名" : Variant/String : ThisWorkbook.Ex2
    
15.         '  E.Value(1,2) : "地區" : Variant/String : ThisWorkbook.Ex2
    
16.         '  E.Value(1,3) : "性別" : Variant/String : ThisWorkbook.Ex2
    
17.         '  E.Value(1,4) : "教育程度" : Variant/String : ThisWorkbook.Ex2
    
18.         '  E.Value(1,5) : "婚姻" : Variant/String : ThisWorkbook.Ex2
    
19.         '  E.Value(1,6) : "子女" : Variant/String : ThisWorkbook.Ex2
    
20.         Dk(E.Cells(1, 1) & E.Cells(1, 2) & E.Cells(1, 3) & E.Cells(1, 5)) = E.Value
    
21.     Next
    
22.    
    
23.     With Sheet2
    
24.         .Cells.Clear
    
25.         cts = 1
    
26.         For Each E In Dk.KEYS
    
27.             '  UBound(Dk(E), 1) : 1 : Long : ThisWorkbook.Ex
    
28.             '  UBound(Dk(E), 2) : 6 : Long : ThisWorkbook.Ex
    
29.             '  E : "姓名地區性別婚姻" : Variant/String : ThisWorkbook.Ex2
    
30.             '  E : "小李台北女已婚" : Variant/String : ThisWorkbook.Ex2
    
31.             '  E : "小劉桃園男已婚" : Variant/String : ThisWorkbook.Ex2
    
32.             .Cells(cts, "A").Resize(1, UBound(Dk(E), 2)).Value = Dk(E)   '  讀取字典物件的 ITEM (陣列)
    
33.         cts = cts + 1
    
34.         Next
    
35.     End With
    
36. End Sub

複製代碼

請把以上複製的程式碼放入到 ThisWorkbook 程式碼區內執行。
P.S.  目前在我的檔案中 Module1 區亦放入相同程式碼分別測試結果 (Sub 名稱不同)，
        這是為了方便測試 "型態不符" 問題所在之故。

c_c_lai

回復 16# jackyliu
回復 17# GBKEE
問題可能出在

1. D(E.Cells(1, 1) & E.Cells(1, 2) & E.Cells(1, 3) & E.Cells(1, 5)) = E.Value

複製代碼

Hsieh 版大應用了

1. d(mystr) = Application.Transpose(Application.Transpose(a.Resize(, 6).Value))

複製代碼

在陣列值移轉中透過   Application.Transpose()，使得數值得以正確 Assign，其穩定度比直接
Assign 會來得確實、資料 Assigment 中較不易流失。我將 Hsieh 版大的程式加上變數宣告，
載於如下：

1. Sub ex()                                              '  Hsieh
   
2.     Dim d As Object, a As Range, mystr As String
   
3.    
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5. 
   
6.     With Sheet1
   
7.         For Each a In .Range(.[A1], .[A1].End(xlDown))
   
8.             mystr = a & a.Offset(, 1) & a.Offset(, 2) & a.Offset(, 4)
   
9.             '  If d.exists(mystr) Then MsgBox a & "資料重複"
   
10.             d(mystr) = Application.Transpose(Application.Transpose(a.Resize(, 6).Value))
    
11.         Next
    
12.     End With
    
13.    
    
14.     With Sheet2
    
15.         .Cells.ClearContents
    
16.         .[A1].Resize(d.Count, 6) = Application.Transpose(Application.Transpose(d.items))
    
17.     End With
    
18. End Sub

複製代碼

GBKEE

回復 19# c_c_lai
15# 有問到  Hsieh超版 13# 的試了,沒如沒錯誤可照著改試試看   
你18# 程式碼, 只差我沒書明 E As Variant

1. Dim Dk As Object, E As Variant, cts As Integer
   
2.       'Dim Dk As Object, E, cts As Integer

複製代碼

請在我的程式碼版本中,書明 E As Variant 再測試看