用VBA代码对比两列数据，并提取差异数据在新的两列

3190496160

Sub 数据比对()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("0、差异数据")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a4:a" & r)
    .Range("c5:c" & r) = Empty
    rs = .Cells(Rows.Count, 4).End(xlUp).Row
    .Range("f5:f" & rs) = Empty
    br = .Range("d4:d" & rs)
    ReDim arr(1 To UBound(ar), 1 To 1)
    ReDim brr(1 To UBound(br), 1 To 1)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            d(ar(i, 1)) = i
        End If
    Next i
    For i = 2 To UBound(br)
        If Trim(br(i, 1)) <> "" Then
            dc(br(i, 1)) = i
            If Not d.exists(br(i, 1)) Then
                n = n + 1
                brr(n, 1) = br(i, 1)
            End If
        End If
    Next i '''d列有而a列无
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            If Not dc.exists(ar(i, 1)) Then
                m = m + 1
                arr(m, 1) = ar(i, 1)
            End If
        End If
    Next i '''a列有而d列无
   If m <> "" Then .[c5].Resize(m, 1) = arr
    If n <> "" Then .[f5].Resize(n, 1) = brr
End With


End Sub

3190496160

对账工具（全部）.rar (1.02 MB, 下载次数: 15)

2023-1-3 13:44 上传

点击文件名下载附件

3190496160

代码是猜着写的，仅供参考
结果分别写入c列和f列

cui26896

审核中，请参考附件

两列数据.zip (640.63 KB, 下载次数: 8)

2023-1-3 15:18 上传

点击文件名下载附件

cui26896

1. Sub comp1()
   
2.   Dim ar As Variant, br As Variant
   
3.   Dim mr As Long, tmpa As Variant, tmpd As Variant
   
4.   Dim ardiffa As Variant, ardiffd As Variant
   
5.   Dim dica As Object, dicd As Object
   
6.   Dim i&, j&, k&
   
7.   Dim lngCT&, lngCTa&, lngCTd&
   
8.   Dim TTL#, MNTa#, MNTd#
   
9.   Dim strtmp As String
   
10.   Set dica = CreateObject("Scripting.Dictionary")
    
11.   Set dicd = CreateObject("Scripting.Dictionary")
    
12.   
    
13.   With Worksheets("0、差异数据")
    
14.     .Activate
    
15.     ReDim tmpa(1 To .Cells(Rows.Count, "A").End(xlUp).Row - 4, 1 To 2)
    
16.     ReDim tmpd(1 To .Cells(Rows.Count, "d").End(xlUp).Row - 4, 1 To 2)
    
17.     If .Cells(Rows.Count, "A").End(xlUp).Row > .Cells(Rows.Count, "D").End(xlUp).Row Then
    
18.       mr = .Cells(Rows.Count, "A").End(xlUp).Row
    
19.       Else
    
20.         mr = .Cells(Rows.Count, "D").End(xlUp).Row
    
21.     End If
    
22.       ReDim ar(1 To mr - 4, 1 To 2)
    
23.       For i = 5 To mr
    
24.         ar(i - 4, 1) = .Cells(i, 1): ar(i - 4, 2) = .Cells(i, 4)
    
25.       Next
    
26.   End With
    
27.     For i = 1 To UBound(ar)
    
28.       MNTa = MNTa + ar(i, 1)
    
29.       If Len(ar(i, 2)) Then MNTd = MNTd + ar(i, 2)
    
30.       If Len(ar(i, 1)) And dica.exists(ar(i, 1)) = False Then
    
31.         dica(ar(i, 1)) = i
    
32.       End If
    
33.         If Len(ar(i, 2)) And dicd.exists(ar(i, 2)) = False Then
    
34.           dicd(ar(i, 2)) = i
    
35.         End If
    
36.     Next
    
37.       TTL = MNTa + MNTd
    
38.       For i = 2 To UBound(ar)
    
39.         If dica.exists(ar(i, 2)) Then
    
40.           dica.Remove ar(i, 2)
    
41.         End If
    
42.           If dicd.exists(ar(i, 1)) Then
    
43.             dicd.Remove ar(i, 1)
    
44.           End If
    
45.       Next
    
46.       br = dicd.items
    
47.       If dica.Count > 1 Then ReDim ardiffa(1 To dica.Count, 1 To 1)
    
48.       If dicd.Count > 1 Then ReDim ardiffd(1 To dicd.Count, 1 To 1)
    
49.         For i = 1 To UBound(ar)
    
50.           If i = dica(ar(i, 1)) Then
    
51.             tmpa(dica(ar(i, 1)), 1) = ar(i, 1): tmpa(dica(ar(i, 1)), 2) = "财政有，前台没有"
    
52.             lngCTa = lngCTa + 1
    
53.             ardiffa(lngCTa, 1) = ar(dica(ar(i, 1)), 1)
    
54.           End If
    
55.             If i = dicd(ar(i, 2)) Then
    
56.               tmpd(dicd(ar(i, 2)), 1) = ar(i, 2): tmpd(dicd(ar(i, 2)), 2) = "前台有，财政没有"
    
57.               lngCTd = lngCTd + 1
    
58.               ardiffd(lngCTd, 1) = ar(dicd(ar(i, 2)), 2)
    
59.             End If
    
60.         Next
    
61.       With Worksheets("0、差异数据")
    
62.         .Range("a3").ClearContents: .Range("d3").ClearContents: .Range("h1:h3").ClearContents
    
63.         .Range("b5:c" & mr).ClearContents: .Range("e5:f" & UBound(tmpd)).ClearContents
    
64.         .Range("a3") = MNTa: .Range("h1") = MNTa:   .Range("d3") = MNTd: .Range("h2") = MNTd: .Range("h3") = MNTa - MNTd
    
65.         .Range("b5:c" & mr) = tmpa: Range("e5:f" & UBound(tmpd)) = tmpd
    
66.       End With
    
67. End Sub

复制代码

cui26896

cui26896 发表于 2023-1-3 15:19

For i = 2 To UBound(ar)虽然不影响最终结果，但是是错误的，应该是For i = 1 To UBound(ar)

554700056

不知道是不是这个意思，运行main就行，在b，d输出值，出现次数，f，g输出a有d没有，d有a没有。请大佬批评指正！