两列同时相同找异同求助

14587

两个工作表A、B列同时比较，若sheet2中与sheet1相同，则放在sheet3中，若sheet2中有，但sheet1中没有的，则放在sheet4中，求帮忙，谢谢！

shiruiqiang

shiruiqiang

Sub test()
Dim arr, brr, crr(1 To 10000, 1 To 2), drr(1 To 10000, 1 To 2)
Dim dic
Set dic = CreateObject("scripting.dictionary")
arr = Sheets(1).[a1].CurrentRegion
For x = 2 To UBound(arr)
If Len(arr(x, 1) & arr(x, 2)) Then
dic(arr(x, 1) & "|" & arr(x, 2)) = ""
End If
Next

brr = Sheets(2).[a1].CurrentRegion
For i = 2 To UBound(brr)
If dic.exists(brr(i, 1) & "|" & brr(i, 2)) Then
m = m + 1
drr(m, 1) = brr(i, 1)
drr(m, 2) = "'" & brr(i, 2)
dic.Remove brr(i, 1) & "|" & brr(i, 2)
Else
k = k + 1
crr(k, 1) = brr(i, 1)
crr(k, 2) = "'" & brr(i, 2)
End If
Next

If m > 0 Then
Sheets(3).[a2].Resize(m, 2) = drr
End If

If k > 0 Then
Sheets(4).[a2].Resize(k, 2) = crr
End If


End Sub

z865593849

1. Sub sql()
   
2. Dim sql As String
   
3. Set conn = New ADODB.Connection
   
4. conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
   
5. & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
   
6. sql = "SELECT a.* FROM [Sheet1$A:B] a inner JOIN [Sheet2$A:B] b ON a.姓名 = b.姓名"
   
7. Sheets("Sheet3").Range("A2").CopyFromRecordset conn.Execute(sql)
   
8. 
   
9. sql = "SELECT * FROM [Sheet2$A:B] " _
   
10.     & " where 姓名 not in  (select 姓名 FROM [Sheet1$A:B])  "
    
11. Sheets("Sheet4").Range("A2").CopyFromRecordset conn.Execute(sql)
    
12. End Sub
    
13. 
    
14. 
    

复制代码

lcluck2002

交个作业。。。。

一招秒杀

这么简单的问题，用两三个函数就搞定了，为啥你们这么喜欢写一大堆代码？一看到那么多代码就让人头疼脑壳痛。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&, isFlag As Boolean
   
    Application.ScreenUpdating = False
    ReDim ar(1 To 2)
    For i = 1 To 2
        ar(i) = Worksheets(i).[A1].CurrentRegion.Value
    Next i
    br = ar(2): r = 1
    For i = 2 To UBound(ar(2))
        For j = 2 To UBound(ar(1))
            If ar(1)(j, 2) = ar(2)(i, 2) Then
                r = r + 1
                br(r, 1) = ar(1)(j, 1)
                br(r, 2) = ar(1)(j, 2)
            End If
        Next j
    Next i
    With Worksheets(3)
        .Cells.Clear
        If r > 1 Then
            With .[A1].Resize(r, 2)
                .NumberFormatLocal = "@"
                .Value = br
            End With
        End If
    End With
   
    br = ar(2): r = 1
    For i = 2 To UBound(ar(2))
        isFlag = False
        For j = 2 To UBound(ar(1))
            If ar(1)(j, 2) = ar(2)(i, 2) Then isFlag = True
        Next j
        If isFlag = False Then
            r = r + 1
            br(r, 1) = ar(2)(i, 1)
            br(r, 2) = ar(2)(i, 2)
        End If
    Next i
    With Worksheets(4)
        .Cells.Clear
        If r > 1 Then
            With .[A1].Resize(r, 2)
                .NumberFormatLocal = "@"
                .Value = br
            End With
        End If
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

纯数组写一个

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet2.Range("a1").CurrentRegion.Value
   
5. ReDim brr(1 To 10000, 1 To 2)
   
6. ReDim crr(1 To 10000, 1 To 2)
   
7. For i = 2 To UBound(arr)
   
8.     s = arr(i, 1) & arr(i, 2)
   
9.     dic(s) = ""
   
10. Next
    
11. drr = Sheet1.Range("a1").CurrentRegion.Value
    
12. For i = 2 To UBound(drr)
    
13.     s = drr(i, 1) & drr(i, 2)
    
14.     If dic.exists(s) Then
    
15.         m = m + 1
    
16.         brr(m, 1) = drr(i, 1): brr(m, 2) = drr(i, 2)
    
17.    
    
18.     Else
    
19.         n = n + 1
    
20.         crr(n, 1) = drr(i, 1): crr(n, 2) = drr(i, 2)
    
21.     End If
    
22. Next
    
23. Sheet3.Range("a2").Resize(m, 2) = brr
    
24. Sheet4.Range("a2").Resize(n, 2) = crr
    
25. Set dic = Nothing
    
26. End Sub
    

复制代码

Qs18

试试..........