12
返回列表 上一主題 發帖

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

loyyee

帖子
42 
主題
9 
精華
0 
積分
64 
點名
0  
作業系統
WINDOW7 
軟體版本
OFFICE2003 
閱讀權限
20 
性別
男 
註冊時間
2011-9-3 
最後登錄
2013-6-10 

論壇榮譽勳章論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2011-10-8 01:12 | 只看該作者

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

本帖最後由 loyyee 於 2011-10-15 09:11 編輯

數值比對.rar (9.97 KB) 請問如何比對出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

帖子
824 
主題
6 
精華
0 
積分
904 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2023-12-24 
2#
發表於 2011-10-8 07:52 | 只看該作者
回復 1# loyyee
數值比對-Ans.zip (29.08 KB)

TOP

loyyee

帖子
42 
主題
9 
精華
0 
積分
64 
點名
0  
作業系統
WINDOW7 
軟體版本
OFFICE2003 
閱讀權限
20 
性別
男 
註冊時間
2011-9-3 
最後登錄
2013-6-10 

論壇榮譽勳章論壇贊助勳章
3#
發表於 2011-10-8 09:36 | 只看該作者
回復 2# luhpro

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

TOP

luhpro

帖子
824 
主題
6 
精華
0 
積分
904 
點名
0  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2023-12-24 
4#
發表於 2011-10-8 10:02 | 只看該作者
回復 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)

TOP

loyyee

帖子
42 
主題
9 
精華
0 
積分
64 
點名
0  
作業系統
WINDOW7 
軟體版本
OFFICE2003 
閱讀權限
20 
性別
男 
註冊時間
2011-9-3 
最後登錄
2013-6-10 

論壇榮譽勳章論壇贊助勳章
5#
發表於 2011-10-8 10:27 | 只看該作者
回復 4# luhpro

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

TOP

oobird
　頭銜: 街友一族

超級版主Rank: 8Rank: 8

帖子
1572 
主題
16 
精華
2 
積分
1521 
點名
0  
作業系統
xp 
軟體版本
office 2003 
閱讀權限
150 
性別
男 
註冊時間
2010-5-1 
最後登錄
2016-1-13 

論壇貢獻勳章
6#
發表於 2011-10-8 11:14 | 只看該作者
本帖最後由 oobird 於 2011-10-8 11:18 編輯
  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
複製代碼

TOP

loyyee

帖子
42 
主題
9 
精華
0 
積分
64 
點名
0  
作業系統
WINDOW7 
軟體版本
OFFICE2003 
閱讀權限
20 
性別
男 
註冊時間
2011-9-3 
最後登錄
2013-6-10 

論壇榮譽勳章論壇贊助勳章
7#
發表於 2011-10-8 11:35 | 只看該作者
回復 6# oobird

感謝版主協助修改。

TOP

dechiuan999

帖子
231 
主題
55 
精華
0 
積分
293 
點名
0  
作業系統
winxp 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
KEELUNG 
註冊時間
2010-7-24 
最後登錄
2018-8-28 
8#
發表於 2011-10-8 15:30 | 只看該作者
你好：
   
     你的提問讓我也有學習的機會。
謝謝你！
請試試下列是否可適用。
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

TOP

loyyee

帖子
42 
主題
9 
精華
0 
積分
64 
點名
0  
作業系統
WINDOW7 
軟體版本
OFFICE2003 
閱讀權限
20 
性別
男 
註冊時間
2011-9-3 
最後登錄
2013-6-10 

論壇榮譽勳章論壇贊助勳章
9#
發表於 2011-10-8 16:33 | 只看該作者
回復 8# dechiuan999

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

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

TOP

dechiuan999

帖子
231 
主題
55 
精華
0 
積分
293 
點名
0  
作業系統
winxp 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
KEELUNG 
註冊時間
2010-7-24 
最後登錄
2018-8-28 
10#
發表於 2011-10-9 07:13 | 只看該作者
本帖最後由 dechiuan999 於 2011-10-9 09:08 編輯

你好：

   請再試試如下：
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

TOP

        靜思自在 : 人生不一定球球是好球，但是有歷練的強打者，隨時都可以揮棒。
12
返回列表 上一主題