银行对账工具更新版

几年前刚学VBA，写过一个银行流水和ERP系统做账记录进行金额比对的工具。做为一名财务人员，经常会遇到这样的需求。

当时只是为了学习VBA字典，数组等知识而写，多年使用中发现有很多问题，最难受的就是效率一般，数据量特别大的时候，明显

有卡顿，一直想重新写一个，但平时实质比较忙，加上早已经不把VBA作为主技能树。所以一直没放在心上，最近有很多同事说喜

欢用我写的这个小工具，突然就有了一种责任感。于是重新写了一版。

一气呵成，简单的测试了一下。难免有逻辑漏洞，欢迎喜欢的朋友们下载使用，发现错误，提出建议。

地址是：下载地址

很久没有上传资源，今天上传一下发现下载积分是5，并且没找到可以修改积分的地方，对于我这样的爱好共享的人来说，实在不

忍心。所以把代码放下面。

你可以根据放到VBA的模块里。

 

 

Option Base 1

Sub compare()


Dim arr1, arr2 'arr1,2,分别存储2列原始数据

Dim restarr1(), restarr2() '分别存储arr1,2 相对多的数据  或者说结果要展示的2列数据
Dim i, j, k, m, n, start
Dim find As Boolean
Dim sh As Worksheet

Application.ScreenUpdating = False

Set sh = ThisWorkbook.Sheets("数据比对") '这个根据你自己的工作表设置
With sh

.Columns("e:h").ClearContents

'老样子数据分别A，C两列
'差异分别放在E G两列
arr1 = Application.Transpose(.Range("a2:a" & .[a65536].End(xlUp).Row)) 
arr2 = Application.Transpose(.Range("c2:c" & .[c65536].End(xlUp).Row))

End With

start = 1
k = 1
m = 1
[e1] = [a1] & "多的数据"
[g1] = [c1] & "多的数据"

On Error GoTo ErrCateg

For i = 1 To UBound(arr1)
        
        find = False
          
          
        For j = start To UBound(arr2)
                    
                    If arr2(j) = arr1(i) Then
                     
                        find = True
                        start = j + 1
                        Exit For
                    
                    ElseIf arr2(j) > arr1(i) Then
                        start = j
                        Exit For
                        
                    Else
                         ReDim Preserve restarr2(1 To k)
                         restarr2(k) = arr2(j)
                         k = k + 1
                         start = start + 1
             
           
                    End If
           Next
           
         If find = False Then  '如果没有相等的，那么A列的这个数字就是 A列多出的。
         
            ReDim Preserve restarr1(1 To m)
            restarr1(m) = arr1(i)
            m = m + 1
            End If

Next



If start <= UBound(arr2) Then

For n = start To UBound(arr2)
     ReDim Preserve restarr2(1 To k)
                restarr2(k) = arr2(n)
                k = k + 1
Next


End If



If m > 1 Then ' 如果A列有多的数据那么显示。 如果没有的话 下面的语句会出错，所以需要m 判断一下
[e2].Resize(m - 1, 1) = Application.Transpose(restarr1)
End If

If k > 1 Then

[g2].Resize(k - 1, 1) = Application.Transpose(restarr2)
End If

Application.ScreenUpdating = True

Exit Sub

ErrCateg:

MsgBox "请确保每列数据至少有2个！"

Application.ScreenUpdating = True

End Sub

 

补充：

因为是在原来的版本基础上修改代码。自动排序的代码没改动，所以没提供，如果需要的话请继续看下面。

在VBE中点击放数据的Sheet，然后选择 worksheet 对象的 change 方法 

应该会自动把方法体构建好。最后代码如下：A,C,E,G是用到数据列以及差异展示列。请自己根据你的情况修改。

Private Sub Worksheet_Change(ByVal Target As Range)
    Range("A:A").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
    Range("C:C").Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
        Range("E:E").Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
        Range("G:G").Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
End Sub