[發問] 檢查重複性質的資料

jackyliu

檢查重複性質的資料
大大: 可否幫忙解惑一下,VBA 寫法,
1. 將Sheet1 的資料,複製到Sheet2 的 A1 位置開始,依序寫入.
2. 重複性的資料,不要再重複複製到Sheet2
3. 比較不可重複欄位:姓名,地區,性別,婚姻
以上感恩 ~

GBKEE

回復 1# jackyliu
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, E, I As Integer
   
4.     Set D = CreateObject("Scripting.dictionary")             '字典物件
   
5.     For Each E In Sheet1.Range("a1").CurrentRegion.Rows      '物件: A1所延伸範圍的列
   
6.          D(E.Cells(1, 1) & E.Cells(1, 2) & E.Cells(1, 3) & E.Cells(1, 5)) = E.Value
   
7.     Next
   
8.     With Sheet2
   
9.         .Cells.Clear
   
10.         I = 1
    
11.         For Each E In D.KEYS
    
12.             .Cells(I, "A").Resize(1, UBound(D(E), 2)) = D(E)   '讀取字典物件的ITEM(陣列)
    
13.         I = I + 1
    
14.         Next
    
15.     End With
    
16. End Sub

複製代碼

jackyliu

程式直到這行就出現錯誤了,會是宣告的問題還是我Execl資料有數字,英文,中文 的關係嗎?

.Cells(I, "A").Resize(1, UBound(D(E), 2)) = D(E)   '讀取字典物件的ITEM(陣列)

執行階段錯誤'13'
型態不符

GBKEE

回復 3# jackyliu
給的程式碼是以 Sheet1A1所延伸範圍的列 為 Sheet1 的資料
For Each E In Sheet1.Range("a1").CurrentRegion.Rows      '物件: A1所延伸範圍的列
你測試檔案中 Sheet1 的資料 在哪裡?? 須附上你測試檔才了解

jackyliu

感謝板大用心....
    For Each E In Sheet1.Range("a1").CurrentRegion.Rows      '物件: A1所延伸範圍的列
         D(E.Cells(1, 1) & E.Cells(1, 2) & E.Cells(1, 3) & E.Cells(1, 5)) = E.Value
    Next
以上程式說明: 搜尋整數變數E 範圍是Sheet1的A1列的範圍,將搜尋到的第1,2,3,5欄的E值給變數D,持續搜尋行列資料,直到沒有資料為止.

    With Sheet2
        .Cells.Clear
        I = 1
        For Each E In D.KEYS
            .Cells(I, "A").Resize(1, UBound(D(E), 2)) = D(E)   '讀取字典物件的ITEM(陣列)
        I = I + 1
        Next
    End With
以上程式說明: Sheet2所有資料清除,從陣列變數D裡搜尋陣列變數E的值,將每一行列的值,依序寫入Sheet2

從code 理解的看法說明如上, 不知道解釋有誤嗎? 請教導!
可否幫忙教導程式如何判定已存在,有重複內容,不執行寫入Sheet2裡,好嗎?

並附上有錯誤的檔案,如附件!

GBKEE

回復 5# jackyliu
可能是版本的差異2000版沒用過,不知錯誤在哪裡,2003執行沒有錯誤的
請找出錯誤點如圖

下載 (30.97 KB)

2013-7-24 06:39

何判定已存在,有重複內容,不執行寫入Sheet2裡
程式碼如下

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D1 As Object, D2 As Object, E, I As Integer, S As String
   
4.     Set D1 = CreateObject("Scripting.dictionary")                   '字典物件
   
5.     Set D2 = CreateObject("Scripting.dictionary")                   '字典物件
   
6.     For Each E In Sheet1.Range("a1").CurrentRegion.Rows             '物件: A1所延伸範圍的列
   
7.          S = E.Cells(1, 1) & E.Cells(1, 2) & E.Cells(1, 3) & E.Cells(1, 5)  'S=>key值
   
8.          D1(S) = E.Value                                            '有相同的key值-> E範圍的值(陣列) 讀入到Item
   
9.          D2(S) = D2(S) + 1                                          '有相同的key值-> item +1
   
10.     Next
    
11.     With Sheet2
    
12.         .Cells.Clear
    
13.         I = 1
    
14.         For Each E In D2.KEYS
    
15.             If D2(E) = 1 Then                                       'D2沒重覆的key值 -> item= 1
    
16.                 .Cells(I, "A").Resize(1, UBound(D1(E), 2)) = D1(E)  '讀取D1相同的key值: 導入D1的Item(陣列)
    
17.                 I = I + 1
    
18.             End If
    
19.         Next
    
20.     End With
    
21. End Sub

複製代碼

c_c_lai

回復 4# GBKEE

1.         For Each E In D.KEYS
   
2.             .Cells(I, "A").Resize(1, UBound(D(E), 2)) = D(E)
   

複製代碼

我偵測的結果：(Office 2010)
當 E 傳入值為 "無" 時，它就會產生 "型態不符" 的訊息。
我用 Debug 模式逐一執行，觀察相關變數的存入值之變化，

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

複製代碼

當發現 E.Value 莫名為 "無' 時，便知大勢已去。但非每次如此，只要是有此現象
接下來的執行都是  "型態不符"。 此時，再將程式碼重新儲存、喝杯茶再重新執行，
它舒暢了便又正常執行了。
這極可能是 Office 潛在的 Bug， 亦即 E 值的型態判定之問題，使得代入值會無端
變為 "無"。
P.S.  我在 ThisWorkbook、以及 Module1 分別執行都曾發生此異狀。

GBKEE

回復 7# c_c_lai
煩請在加上.Value測試看看

1.         For Each E In D.KEYS
   
2.             .Cells(I, "A").Resize(1, UBound(D(E), 2)).Value = D(E)

複製代碼

c_c_lai

回復 8# GBKEE
絕對不是 .Value 的因素，
.Cells(cts, "A").Resize(1, UBound(Dk(E), 2)) = Dk(E) 與
.Cells(cts, "A").Resize(1, UBound(Dk(E), 2)).Value = Dk(E)
其實都是同等意義，因為在一進入 For Each E In D.KEYS 後即偵測到
值為 "無" 的情況  (此現象才令人百思不解)。
只要沒異狀發生，接下多次執行都是 OK，
反之、則均是 "型態不符"。理論上是不該有的錯誤，我亦試著
將 E 明確宣告為 Variant， 只要發生異狀神仙也無解，
只能等它氣消了！

P. S. 順便請教，最近網頁是不是被更改到了，
         我的右上角個人資訊只顯示
[module]邊欄模塊_我的助手[/module]

GBKEE

回復 9# c_c_lai
辛苦了,請換個變數名稱試試看

1. For Each K In D.KEYS
   
2.             .Cells(I, "A").Resize(1, UBound(D(K), 2)) = D(K)   

複製代碼