两表提取不同

ww0000

根据表三中红色字的要求，分别从表一和表二中提取内容到表三 两表比较.rar (1.9 KB, 下载次数: 17)

2025-4-2 16:47 上传

点击文件名下载附件

shiruiqiang

表1字典，值：表1有表2没有
循环表2，dic.exists就是值修改为表1和表2都有，否则表2有

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()   '//2025.4.2
   
2.     Application.ScreenUpdating = False
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     Set d2 = CreateObject("Scripting.Dictionary")
   
5.     arr = Sheets("表一").UsedRange
   
6.     For j = 1 To UBound(arr, 2) Step 2
   
7.         For i = 1 To UBound(arr)
   
8.             s = arr(i, j)
   
9.             d1(s) = ""
   
10.         Next
    
11.     Next
    
12.     arr = Sheets("表二").UsedRange
    
13.     For j = 1 To UBound(arr, 2) Step 2
    
14.         For i = 1 To UBound(arr)
    
15.             s = arr(i, j)
    
16.             d2(s) = ""
    
17.         Next
    
18.     Next
    
19.     ReDim brr(1 To d1.Count, 1 To 2)
    
20.     m = 0
    
21.     For Each k In d1.keys
    
22.         If Not d2.exists(k) Then
    
23.             m = m + 1
    
24.             brr(m, 1) = k
    
25.         End If
    
26.     Next
    
27.     mx = IIf(mx < m, m, mx)
    
28.     m = 0
    
29.     For Each k In d2.keys
    
30.         If Not d1.exists(k) Then
    
31.             m = m + 1
    
32.             brr(m, 2) = k
    
33.         End If
    
34.     Next
    
35.     mx = IIf(mx < m, m, mx)
    
36.     With Sheets("表三")
    
37.         .UsedRange.Offset(1) = Empty
    
38.         .[a2].Resize(mx, 2) = brr
    
39.     End With
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "OK！"
    
42. End Sub
    
43. 
    

复制代码

gwjkkkkk

Option Explicit
Sub test2()
    Dim ar, br, i&, j&, k&, r&, n&, strJoin$
   
    Application.ScreenUpdating = False
   
    ReDim ar(1 To 2): ReDim br(1 To 10 ^ 3, 0)
    With Worksheets(3)
        .[A1].CurrentRegion.Offset(1).Clear
        For i = 1 To 2
            ar(i) = Worksheets(i).[A2].CurrentRegion.Value
        Next i
        For i = 1 To 2
            r = 0: strJoin$ = ""
            If i = 1 Then n = 2 Else n = 1
            For k = 1 To UBound(ar(n))
                For j = 1 To UBound(ar(n), 2) Step 2
                    strJoin = strJoin & "," & ar(n)(k, j)
                Next j
            Next k
            strJoin = strJoin & ","
            For k = 1 To UBound(ar(i))
                For j = 1 To UBound(ar(i), 2) Step 2
                    If InStr(strJoin, ar(i)(k, j)) = 0 Then
                        r = r + 1
                        br(r, 0) = ar(i)(k, j)
                    End If
                Next j
            Next k
            If r Then .Cells(2, i).Resize(r) = br
        Next i
        .Activate
    End With
        
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

ww0000

Sub lkyy()
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
sht1 = Sheet1.UsedRange
sht2 = Sheet2.UsedRange
For Each ii In sht1
    If Len(ii) > 0 Then d1(ii) = ""
Next
For Each ii In sht2
    If Len(ii) > 0 Then
        If d1.exists(ii) Then
            d3(ii) = ""
        Else
            d2(ii) = ""
        End If
    End If
Next
For Each k In d1
    If d3.exists(k) Then d1.Remove (k)
Next
Range("a2:c10000").ClearContents
Range("a2").Resize(d1.Count, 1) = Application.Transpose(d1.keys)
Range("b2").Resize(d2.Count, 1) = Application.Transpose(d2.keys)
Range("c2").Resize(d3.Count, 1) = Application.Transpose(d3.keys)
End Sub

这个怎样才能只对比
Sheet1.Range("A2:A4,C2:C4")
Sheet2.Range("A2:A4,C2:C4")

cai2532

如此优秀的实例必须好好学习。

ww0000

老师，这个为什么不行呀？
Sub lkyy()
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
sht1 =Sheet1.Range("A2:A4,C2:C4")
sht2 = Shee2.Range("A2:A4,C2:C4")
For Each ii In sht1
    If Len(ii) > 0 Then d1(ii) = ""
Next
For Each ii In sht2
    If Len(ii) > 0 Then
        If d1.exists(ii) Then
            d3(ii) = ""
        Else
            d2(ii) = ""
        End If
    End If
Next
For Each k In d1
    If d3.exists(k) Then d1.Remove (k)
Next
Range("a2:c10000").ClearContents
Range("a2").Resize(d1.Count, 1) = Application.Transpose(d1.keys)
Range("b2").Resize(d2.Count, 1) = Application.Transpose(d2.keys)
Range("c2").Resize(d3.Count, 1) = Application.Transpose(d3.keys)
End Sub

ww0000

gwjkkkkk 发表于 2025-4-2 19:12

老师，下面的两段代码，为什么第二种就不行呢？


Sub lkyy()
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
sht1 = Sheet1.UsedRange
sht2 = Sheet2.UsedRange

Sub lkyy()
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
sht1 =Sheet1.Range("A2:A4,C2:C4")
sht2 = Shee2.Range("A2:A4,C2:C4")