[發問] 如何比對出A/B欄重複及欠缺之數值

loyyee

數值比對.rar (9.97 KB)

下載次數: 16

2011-10-8 01:12

請問如何比對出A/B欄重複及欠缺之數值?

A欄            B欄
A0001        A0001
A0002        A0002
A0003        A0003
A0003        A0004
A0005        A0004
A0007        A0006

A欄重複數值:A0003
A欄欠缺數值:A0004.A0006
B欄重複數值:A0004
B欄欠缺數值:A0005.A0007

luhpro

回復 1# loyyee
數值比對-Ans.zip (29.08 KB)

下載次數: 19

2011-10-8 07:52

loyyee

回復 2# luhpro

感謝解答，如果A/B欄數量不相等時會出現錯誤，請問該如何修改? 數值比對-Ans.rar (20.8 KB)

下載次數: 13

2011-10-8 09:35

luhpro

回復 3# loyyee
剛剛發現原程式有兩個地方有錯誤之前沒有注意到 :
  If .Cells(lTarRow(iLack) - 1, iLack) <> "A" & Right("0000" & lCount, 4) Then
與
  .Value = "A" & Right("0000" & lCount, 4)
lCount 要改成 lJ

修改程式如下:
數值比對-Ans2.zip (28.63 KB)

下載次數: 8

2011-10-8 10:01

loyyee

回復 4# luhpro

感謝修改程式可以用了，要花點時間研究巨集。

oobird

1. Private Sub cbCheckData_Click()
   
2.     Dim a As Range, b As Range, e%, f%, r%
   
3.     Set a = Range(Cells(1, 1), Cells(1, 1).End(xlDown))
   
4.     Set b = Range(Cells(1, 2), Cells(1, 2).End(xlDown))
   
5.     e = 7: f = 7
   
6.     For r = 1 To a.Count
   
7.         If Application.CountIf(b, a(r)) = 0 And [j:j].Find(a(r), , , 1) Is Nothing Then [j65536].End(xlUp).Offset(1, 0) = a(r)
   
8.         If Application.CountIf(a, a(r)) > 1 And [e:e].Find(a(r), , , 1) Is Nothing Then Cells(e, 5) = a(r): e = e + 1
   
9.     Next
   
10.     For r = 1 To b.Count
    
11.         If Application.CountIf(a, b(r)) = 0 And [i:i].Find(b(r), , , 1) Is Nothing Then [i65536].End(xlUp).Offset(1, 0) = b(r)
    
12.         If Application.CountIf(b, b(r)) > 1 And [f:f].Find(b(r), , , 1) Is Nothing Then Cells(f, 6) = b(r): f = f + 1
    
13.     Next
    
14. End Sub

複製代碼

loyyee

回復 6# oobird

感謝版主協助修改。

dechiuan999

你好：
   
     你的提問讓我也有學習的機會。
謝謝你！
請試試下列是否可適用。
Sub aa()
   
    Dim mSht As Worksheet
    Dim mRng1 As Range, mRng2 As Range, E As Range   
    Dim mDic1 As Object
    Dim mDic2 As Object   
    Dim mData1(), mData2()
    Dim s1%, s2%
    Dim key1, key2
   
    Set mDic1 = CreateObject("scripting.dictionary")
    Set mDic2 = CreateObject("scripting.dictionary")
   
    Set mSht = Worksheets(1)
    With mSht
        Set mRng1 = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
        Set mRng2 = .Range("b1", .Range("b" & .Rows.Count).End(xlUp))
      
        For Each E In mRng1
            If Not mDic1.Exists(E.Value) Then
                mDic1.Add (E.Value), E.Value
            Else
                ReDim Preserve mData1(s1)
                mData1(s1) = E.Value
                s1 = s1 + 1
            End If
        Next        
               
        For Each E In mRng2
            If Not mDic2.Exists(E.Value) Then
                mDic2.Add (E.Value), E.Value
            Else
                ReDim Preserve mData2(s2)
                mData2(s2) = E.Value
                s2 = s2 + 1
            End If
        Next
        .Range("e6") = "重複數值"
        .Range("e6:f6").Merge
        .Range("e7").Resize(s1) = Application.Transpose(mData1)
        .Range("f7").Resize(s2) = Application.Transpose(mData2)
        'mKey2 = mDic2.Keys
        'mItem2 = mDic2.Items
        
        Erase mData1
        Erase mData2
        s1 = 0
        s2 = 0
        
        For Each key1 In mDic1.Keys
            If key1 <> mDic2(key1) Then
                ReDim Preserve mData1(s1)
                mData1(s1) = key1
                s1 = s1 + 1
            End If
        Next
        
        For Each key2 In mDic2.Keys
            If key2 <> mDic1(key2) Then
                ReDim Preserve mData2(s2)
                mData2(s2) = key2
                s2 = s2 + 1
            End If
        Next
        
        .Range("i1") = "A欄缺之數值"
        .Range("j1") = "B欄缺之數值"
        
        .Range("i2").Resize(s1) = Application.Transpose(mData1)
        .Range("j2").Resize(s2) = Application.Transpose(mData2)        
            
    End With
   
    Set mDic1 = Nothing
    Set mDic2 = Nothing
    Set mRng1 = Nothing
    Set mRng2 = Nothing   
   
End Sub

loyyee

回復 8# dechiuan999

感謝您熱心指導巨集可以用，但是有一些問題:
1.遇到數值中間有連續空白時，空白也會被抓到"重複數值"。
2.連續重複數值會都被抓出，抱歉這點我當初沒說清楚重複數值我只要抓一次就好。

數值比對-Ans2.rar (27.57 KB)

下載次數: 7

2011-10-8 16:33

dechiuan999

你好：

   請再試試如下：
Sub aa()
   
    Dim mSht As Worksheet
    Dim mRng1 As Range, mRng2 As Range, E As Range
    Dim mDic1 As Object
    Dim mDic2 As Object
    Dim mData1(), mData2()
    Dim s%, s1%, s2%
   
    Set mDic1 = CreateObject("scripting.dictionary")
    Set mDic2 = CreateObject("scripting.dictionary")        
    Set mSht = Worksheets(1)
    With mSht
        Set mRng1 = .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
        Set mRng2 = .Range("b1", .Range("b" & .Rows.Count).End(xlUp))
      
        For Each E In mRng1
            If E.Value <> "" Then
                mDic1(E.Value) = mDic1(E.Value) + 1
            End If
        Next
      
        
        For Each key1 In mDic1.Keys
            If mDic1(key1) > 1 Then
                ReDim Preserve mData1(s1)
                mData1(s1) = key1
                s1 = s1 + 1
            End If
        Next
               
        For Each E In mRng2
            If E.Value <> "" Then
                mDic2(E.Value) = mDic2(E.Value) + 1
            End If
        Next
        
        For Each key2 In mDic2.Keys
            If mDic2(key2) > 1 Then
                ReDim Preserve mData2(s2)
                mData2(s2) = key2
                s2 = s2 + 1
            End If
        Next
        
               
        .Range("e6") = "重複數值"
        .Range("e6:f6").Merge
        .Range("e7").Resize(s1) = Application.Transpose(mData1)
        .Range("f7").Resize(s2) = Application.Transpose(mData2)
      
        
        Erase mData1
        Erase mData2
        s1 = 0
        s2 = 0
        
        For Each key1 In mDic1.Keys
            If Not mDic2.Exists(key1) Then
                ReDim Preserve mData1(s1)
                mData1(s1) = key1
                s1 = s1 + 1
            End If
        Next
        
        For Each key2 In mDic2.Keys
            If Not mDic1.Exists(key2) Then
                ReDim Preserve mData2(s2)
                mData2(s2) = key2
                s2 = s2 + 1
            End If
        Next
        
        .Range("i1") = "A欄缺之數值"
        .Range("j1") = "B欄缺之數值"
        
        .Range("i2").Resize(s1) = Application.Transpose(mData1)
        .Range("j2").Resize(s2) = Application.Transpose(mData2)
            
    End With
   
    Set mDic1 = Nothing
    Set mDic2 = Nothing
    Set mRng1 = Nothing
    Set mRng2 = Nothing
   
End Sub