Cacher is the code snippet organizer for pro developers

Sub run()
    Dim general() As Double     '总所数据
    Dim division() As Double    '分所数据
    Dim gid As String           '总所表名
    Dim did As String           '分所表名
    Dim m(3) As Excel.Worksheet   '反向匹配表
    
    gid = "总所"
    did = "分所"
    
    '数据读取
    general = read(Sheets(gid), 5)
    division = read(Sheets(did), 4)
    
    '创建匹配表
    Set m(0) = buildMatch(general, division, gid, "fxd", "当月反向")
    Set m(1) = buildMatch(general, division, gid, "fx", "其它反向")
    Set m(2) = buildMatch(general, division, gid, "zxd", "当月正向")
    Set m(3) = buildMatch(general, division, gid, "zx", "其它正向")
    
    '结果统计
    Call buildTotal(m, "汇总表")
End Sub

'读取信息
Function read(s As Excel.Worksheet, ub As Integer) As Double()
    Dim i As Integer, rn As Integer, n As Integer, r As Excel.Range, a() As Double
    
    n = 0
    Set r = s.UsedRange
    rn = r.Rows.Count
    
    For i = ub To rn
        If (r(i, 4).Value <> "") Then
            ReDim Preserve a(5, n) As Double
            a(0, n) = i     '行号
            a(1, n) = r(i, 6).Value     '借方金额
            a(2, n) = r(i, 7).Value     '借方金额
            a(3, n) = r(i, 2).Value     '月
            a(4, n) = r(i, 1).Value     '年
            n = n + 1
        End If
    Next i
    
    read = a
End Function

'创建或覆盖一个空Sheet
Function getNullSheet(name As String) As Excel.Worksheet
    Dim n As Integer
    
    n = Sheets.Count
    For i = 1 To n
        If (Sheets(i).name = name) Then
            Set getNullSheet = Sheets(i)
            Call getNullSheet.UsedRange.Clear
            Exit For
        End If
    Next i
    
    If (i > n) Then
        Set getNullSheet = Sheets.Add(, Sheets(n))
        getNullSheet.name = name
    End If
End Function

'统计比对结果
Function buildTotal(m() As Excel.Worksheet, name As String) As Excel.Worksheet
    Dim i As Integer, r As Integer, k As Integer, n As Integer, s As Excel.Worksheet
    Set s = getNullSheet(name)
    
    n = m(0).UsedRange.Rows.Count
    For r = 1 To n
        s.Range("A" & r).Formula = m(0).Range("A" & r).Formula     '年
        s.Range("B" & r).Formula = m(0).Range("B" & r).Formula     '月
        s.Range("C" & r).Formula = m(0).Range("C" & r).Formula     '日
        s.Range("D" & r).Formula = m(0).Range("D" & r).Formula     '凭证字号
        s.Range("E" & r).Formula = m(0).Range("E" & r).Formula     '摘要
    Next r
    
    k = 13      'M —— 行标起始位置
    For i = 0 To UBound(m)
        s.Cells(1, k) = m(i).name & "个数"
        For r = 2 To n
            s.Cells(r, k).Formula = "=Count(" & m(i).name & "!" & r & ":" & r & ") - Count(" & m(i).name & "!A" & r & ":L" & r & ")"
        Next r
        k = k + 1
    Next i
    
    s.Cells(1, k) = "总计"
    Dim rs As String
    rs = VBA.Chr(k + 63)
    For r = 2 To n
        s.Cells(r, k).Formula = "=SUM(M" & r & ":" & rs & r & ")"
    Next r
End Function

'创建匹配表
Function buildMatch(g() As Double, d() As Double, gid As String, condition As String, name As String) As Excel.Worksheet
    Dim i As Integer, j As Integer, k As Integer, r As Integer, dn As Integer, gn As Integer, s As Excel.Worksheet
    Set s = getNullSheet(name)
    gn = UBound(g, 2)
    dn = UBound(d, 2)
    
    For i = 0 To gn
        r = g(0, i)
        k = 13      'M —— 行标起始位置
        s.Range("B" & r).Formula = "=" & gid & "!B" & r     '月
        s.Range("C" & r).Formula = "=" & gid & "!C" & r     '日
        s.Range("D" & r).Formula = "=" & gid & "!D" & r     '凭证字号
        s.Range("E" & r).Formula = "=" & gid & "!E" & r     '摘要
        For j = 0 To dn
            If (match(g, d, i, j, condition)) Then '正向匹配条件
                s.Cells(r, k) = d(0, j)
                k = k + 1
            End If
        Next j
    Next i
    
    '第一行填满
    For i = 1 To r
        s.Range("A" & i).Formula = "=" & gid & "!A" & i     '年
    Next i
    
    Set buildMatch = s
End Function

'条件匹配
Function match(g() As Double, d() As Double, i As Integer, j As Integer, condition As String)
    Select Case condition
        Case "fxd"
            match = c_fxd(g, d, i, j)
        Case "zxd"
            match = c_zxd(g, d, i, j)
        Case "fx"
            match = c_fx(g, d, i, j)
        Case "zx"
            match = c_zx(g, d, i, j)
        Case Else
            match = False
    End Select
End Function

'条件——反向（当月）
Function c_fxd(g() As Double, d() As Double, i As Integer, j As Integer) As Boolean
    If ((g(1, i) = d(2, j)) And (g(2, i) = d(1, j)) And ((g(3, i) = d(3, j)) And (g(4, i) = d(4, j)))) Then
        c_fxd = True
    Else
        c_fxd = False
    End If
End Function

'条件——正向（当月）
Function c_zxd(g() As Double, d() As Double, i As Integer, j As Integer) As Boolean
    If ((g(1, i) = -d(1, j)) And (g(2, i) = -d(2, j)) And ((g(3, i) = d(3, j)) And (g(4, i) = d(4, j)))) Then
        c_zxd = True
    Else
        c_zxd = False
    End If
End Function

'条件——反向（非当月）
Function c_fx(g() As Double, d() As Double, i As Integer, j As Integer) As Boolean
    If ((g(1, i) = d(2, j)) And (g(2, i) = d(1, j)) And ((g(3, i) <> d(3, j)) Or (g(4, i) <> d(4, j)))) Then
        c_fx = True
    Else
        c_fx = False
    End If
End Function

'条件——正向（非当月）
Function c_zx(g() As Double, d() As Double, i As Integer, j As Integer) As Boolean
    If ((g(1, i) = -d(1, j)) And (g(2, i) = -d(2, j)) And ((g(3, i) <> d(3, j)) Or (g(4, i) <> d(4, j)))) Then
        c_zx = True
    Else
        c_zx = False
    End If
End Function