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

3190496160 · 发表于 2023-1-3 13:44

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 · 发表于 2023-1-3 13:44

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

3190496160 · 发表于 2023-1-3 13:45

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

cui26896 · 发表于 2023-1-3 15:18

审核中，请参考附件

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

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

Sub comp1()
Dim ar As Variant, br As Variant
Dim mr As Long, tmpa As Variant, tmpd As Variant
Dim ardiffa As Variant, ardiffd As Variant
Dim dica As Object, dicd As Object
Dim i&, j&, k&
Dim lngCT&, lngCTa&, lngCTd&
Dim TTL#, MNTa#, MNTd#
Dim strtmp As String
Set dica = CreateObject("Scripting.Dictionary")
Set dicd = CreateObject("Scripting.Dictionary")
With Worksheets("0、差异数据")
.Activate
ReDim tmpa(1 To .Cells(Rows.Count, "A").End(xlUp).Row - 4, 1 To 2)
ReDim tmpd(1 To .Cells(Rows.Count, "d").End(xlUp).Row - 4, 1 To 2)
If .Cells(Rows.Count, "A").End(xlUp).Row > .Cells(Rows.Count, "D").End(xlUp).Row Then
mr = .Cells(Rows.Count, "A").End(xlUp).Row
Else
mr = .Cells(Rows.Count, "D").End(xlUp).Row
End If
ReDim ar(1 To mr - 4, 1 To 2)
For i = 5 To mr
ar(i - 4, 1) = .Cells(i, 1): ar(i - 4, 2) = .Cells(i, 4)
Next
End With
For i = 1 To UBound(ar)
MNTa = MNTa + ar(i, 1)
If Len(ar(i, 2)) Then MNTd = MNTd + ar(i, 2)
If Len(ar(i, 1)) And dica.exists(ar(i, 1)) = False Then
dica(ar(i, 1)) = i
End If
If Len(ar(i, 2)) And dicd.exists(ar(i, 2)) = False Then
dicd(ar(i, 2)) = i
End If
Next
TTL = MNTa + MNTd
For i = 2 To UBound(ar)
If dica.exists(ar(i, 2)) Then
dica.Remove ar(i, 2)
End If
If dicd.exists(ar(i, 1)) Then
dicd.Remove ar(i, 1)
End If
Next
br = dicd.items
If dica.Count > 1 Then ReDim ardiffa(1 To dica.Count, 1 To 1)
If dicd.Count > 1 Then ReDim ardiffd(1 To dicd.Count, 1 To 1)
For i = 1 To UBound(ar)
If i = dica(ar(i, 1)) Then
tmpa(dica(ar(i, 1)), 1) = ar(i, 1): tmpa(dica(ar(i, 1)), 2) = "财政有，前台没有"
lngCTa = lngCTa + 1
ardiffa(lngCTa, 1) = ar(dica(ar(i, 1)), 1)
End If
If i = dicd(ar(i, 2)) Then
tmpd(dicd(ar(i, 2)), 1) = ar(i, 2): tmpd(dicd(ar(i, 2)), 2) = "前台有，财政没有"
lngCTd = lngCTd + 1
ardiffd(lngCTd, 1) = ar(dicd(ar(i, 2)), 2)
End If
Next
With Worksheets("0、差异数据")
.Range("a3").ClearContents: .Range("d3").ClearContents: .Range("h1:h3").ClearContents
.Range("b5:c" & mr).ClearContents: .Range("e5:f" & UBound(tmpd)).ClearContents
.Range("a3") = MNTa: .Range("h1") = MNTa: .Range("d3") = MNTd: .Range("h2") = MNTd: .Range("h3") = MNTa - MNTd
.Range("b5:c" & mr) = tmpa: Range("e5:f" & UBound(tmpd)) = tmpd
End With
End Sub

复制代码

cui26896 · 发表于 2023-1-3 16:24

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

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

554700056 · 发表于 2023-1-3 17:29

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

		自动登录	找回密码
密码			免费注册

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