Option Explicit
' 运行入口
Public Sub 运行对账()
Dim t0 As Single: t0 = Timer
Dim logPath As String, backupPath As String
Dim ok As Boolean
On Error GoTo EH
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' 备份并记录路径以支持撤销
backupPath = 备份当前工作簿()
If Len(backupPath) = 0 Then Err.Raise 1001, , "备份失败"
ThisWorkbook.Names.Add Name:="LastReconBackup", RefersTo:="""" & backupPath & """"
' 日志文件
logPath = 本次日志路径()
记日志 logPath, "开始对账: " & Now
ok = 执行对账流程(logPath)
记日志 logPath, "对账结束: " & Now & "，耗时秒: " & Format$(Timer - t0, "0.0")
CleanExit:
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
If ok Then
MsgBox "对账完成。日志: " & logPath, vbInformation
End If
Exit Sub
EH:
记日志 logPath, "错误: " & Err.Number & " - " & Err.Description
MsgBox "发生错误: " & Err.Description & vbCrLf & "已在日志中记录。", vbCritical
Resume CleanExit
End Sub
' 撤销（从备份恢复）
Public Sub 撤销上次对账()
On Error GoTo EH
Dim nm As Name, p As String
For Each nm In ThisWorkbook.Names
If LCase$(nm.Name) = LCase$("LastReconBackup") Then
p = Replace(nm.RefersTo, "=", "")
p = Replace(p, """", "")
Exit For
End If
Next
If Len(p) = 0 Then
MsgBox "未找到备份路径。", vbExclamation
Exit Sub
End If
If Dir$(p, vbNormal) = "" Then
MsgBox "备份文件不存在: " & p, vbExclamation
Exit Sub
End If
Dim wb As Workbook
Set wb = Application.Workbooks.Open(p, ReadOnly:=False)
MsgBox "已打开备份文件。请以该文件替换当前文件或另存为。", vbInformation
Exit Sub
EH:
MsgBox "撤销失败: " & Err.Description, vbCritical
End Sub
' 核心流程
Private Function 执行对账流程(ByVal logPath As String) As Boolean
Dim wsSales As Worksheet, wsBank As Worksheet
Dim loSales As ListObject, loBank As ListObject
Dim salesCols As Object, bankCols As Object
Set wsSales = 找表所在工作表("tblSales")
Set wsBank = 找表所在工作表("tblBank")
If wsSales Is Nothing Or wsBank Is Nothing Then Err.Raise 1002, , "未找到表：tblSales 或 tblBank"
Set loSales = wsSales.ListObjects("tblSales")
Set loBank = wsBank.ListObjects("tblBank")
If loSales.DataBodyRange Is Nothing Or loBank.DataBodyRange Is Nothing Then Err.Raise 1003, , "源表没有数据"
Set salesCols = CreateObject("Scripting.Dictionary")
salesCols.CompareMode = 1
salesCols("订单号") = 列序号(loSales, "订单号")
salesCols("客户") = 列序号(loSales, "客户")
salesCols("开票金额") = 列序号(loSales, "开票金额")
salesCols("开票日期") = 列序号(loSales, "开票日期")
Dim idxR As Long: idxR = IIf(存在列(loSales, "已收款标记"), 列序号(loSales, "已收款标记"), 0)
If idxR > 0 Then salesCols("已收款标记") = idxR
Set bankCols = CreateObject("Scripting.Dictionary")
bankCols.CompareMode = 1
bankCols("交易号") = 列序号(loBank, "交易号")
bankCols("摘要") = 列序号(loBank, "摘要")
bankCols("对方账号") = 列序号(loBank, "对方账号")
bankCols("金额") = 列序号(loBank, "金额")
bankCols("入账日期") = 列序号(loBank, "入账日期")
记日志 logPath, "开始清洗数据..."
清洗表金额与日期 loSales, salesCols("开票金额"), salesCols("开票日期")
清洗表金额与日期 loBank, bankCols("金额"), bankCols("入账日期")
Dim salesData As Collection, bankData As Collection
Dim orderDict As Object, custSet As Object
Set orderDict = CreateObject("Scripting.Dictionary"): orderDict.CompareMode = 1
Set custSet = CreateObject("Scripting.Dictionary"): custSet.CompareMode = 1
记日志 logPath, "读取销售数据..."
Set salesData = 读取销售(loSales, salesCols, orderDict, custSet)
记日志 logPath, "销售行数(可见): " & salesData.Count
记日志 logPath, "读取银行数据并预处理摘要..."
Dim hashedOrders As Object: Set hashedOrders = orderDict ' alias
Set bankData = 读取银行(loBank, bankCols, hashedOrders, custSet)
记日志 logPath, "银行行数(可见): " & bankData.Count
' 匹配
Dim mCountExact As Long, mCountTol As Long, mCountOneMany As Long, mCountManyOne As Long
记日志 logPath, "精确匹配开始..."
mCountExact = 匹配_精确_按订单号与金额(salesData, bankData, logPath)
记日志 logPath, "精确匹配完成: " & mCountExact
记日志 logPath, "容差一对一匹配开始..."
mCountTol = 匹配_容差一对一(salesData, bankData, logPath)
记日志 logPath, "容差一对一完成: " & mCountTol
记日志 logPath, "容差一对多(银行多笔->单张发票)开始..."
mCountOneMany = 匹配_一对多_银行到销售(salesData, bankData, logPath)
记日志 logPath, "容差一对多完成: " & mCountOneMany
记日志 logPath, "容差多对一(多发票->单笔入账)开始..."
mCountManyOne = 匹配_多对一_销售到银行(salesData, bankData, logPath)
记日志 logPath, "容差多对一完成: " & mCountManyOne
' 输出
记日志 logPath, "输出结果表..."
输出对账结果 salesData, bankData
记日志 logPath, "应用条件格式与处理意见下拉..."
设置结果格式和数据验证
记日志 logPath, "生成汇总透视..."
生成汇总透视
记日志 logPath, "未匹配清单..."
输出未匹配清单 salesData, bankData
记日志 logPath, "完成: 精确=" & mCountExact & " 一对一=" & mCountTol & " 一对多=" & mCountOneMany & " 多对一=" & mCountManyOne
执行对账流程 = True
End Function
' 读取与预处理：销售
Private Function 读取销售(lo As ListObject, ByVal cols As Object, ByRef orderDict As Object, ByRef custSet As Object) As Collection
Dim col As New Collection
Dim r As Range, i As Long
Dim rng As Range: Set rng = lo.DataBodyRange
For i = 1 To rng.Rows.Count
If Not (rng.Rows(i).Hidden Or rng.Rows(i).EntireRow.Hidden) Then
Set r = rng.Rows(i)
Dim rec As Object: Set rec = CreateObject("Scripting.Dictionary")
rec.CompareMode = 1
rec("Order") = Trim$(CStr(r.Cells(1, cols("订单号")).Value2))
rec("Customer") = Trim$(CStr(r.Cells(1, cols("客户")).Value2))
rec("Amount") = 规范金额(r.Cells(1, cols("开票金额")).Value2)
rec("Date") = 规范日期(r.Cells(1, cols("开票日期")).Value2)
rec("Row") = r.Row
rec("Matched") = False
rec("MatchedBankIdx") = CreateObject("System.Collections.ArrayList")
rec("MatchMode") = ""
rec("MatchDiff") = 0#
If Len(rec("Order")) > 0 Then If Not orderDict.Exists(rec("Order")) Then orderDict(rec("Order")) = True
If Len(rec("Customer")) > 0 Then If Not custSet.Exists(rec("Customer")) Then custSet(rec("Customer")) = True
col.Add rec
End If
Next
Set 读取销售 = col
End Function
' 读取与预处理：银行
Private Function 读取银行(lo As ListObject, ByVal cols As Object, ByVal orderDict As Object, ByVal custSet As Object) As Collection
Dim col As New Collection
Dim rng As Range: Set rng = lo.DataBodyRange
Dim i As Long
For i = 1 To rng.Rows.Count
If Not (rng.Rows(i).Hidden Or rng.Rows(i).EntireRow.Hidden) Then
Dim r As Range: Set r = rng.Rows(i)
Dim rec As Object: Set rec = CreateObject("Scripting.Dictionary")
rec.CompareMode = 1
rec("TxnID") = Trim$(CStr(r.Cells(1, cols("交易号")).Value2))
rec("Summary") = Trim$(CStr(r.Cells(1, cols("摘要")).Value2))
rec("Account") = Trim$(CStr(r.Cells(1, cols("对方账号")).Value2))
rec("Amount") = 规范金额(r.Cells(1, cols("金额")).Value2)
rec("Date") = 规范日期(r.Cells(1, cols("入账日期")).Value2)
rec("Row") = r.Row
rec("Matched") = False
rec("MatchedSalesIdx") = CreateObject("System.Collections.ArrayList")
rec("ExtractOrder") = 从摘要提取订单号(rec("Summary"), orderDict)
rec("GuessCustomer") = 从摘要识别客户(rec("Summary"), custSet)
col.Add rec
End If
Next
Set 读取银行 = col
End Function
' 精确匹配：摘要提取订单号，与销售订单号一致，金额相等
Private Function 匹配_精确_按订单号与金额(ByVal sales As Collection, ByVal bank As Collection, ByVal logPath As String) As Long
Dim i As Long, j As Long, cnt As Long
Dim s As Object, b As Object
' 加速：为订单号建立索引 -> 销售索引列表
Dim mapOrderToIdx As Object: Set mapOrderToIdx = CreateObject("Scripting.Dictionary"): mapOrderToIdx.CompareMode = 1
For i = 1 To sales.Count
Set s = sales(i)
If Not s("Matched") Then
If Len(s("Order")) > 0 Then
If Not mapOrderToIdx.Exists(s("Order")) Then Set mapOrderToIdx(s("Order")) = CreateObject("System.Collections.ArrayList")
mapOrderToIdx(s("Order")).Add i
End If
End If
Next
For j = 1 To bank.Count
Set b = bank(j)
If Not b("Matched") Then
Dim ord As String: ord = CStr(b("ExtractOrder"))
If Len(ord) > 0 Then
If mapOrderToIdx.Exists(ord) Then
' 在该订单的销售中找金额相等的未匹配项
Dim list As Object: Set list = mapOrderToIdx(ord)
Dim k As Long
For k = 0 To list.Count - 1
i = CLng(list(k))
Set s = sales(i)
If Not s("Matched") Then
If Abs(s("Amount") - b("Amount")) < 0.005 Then
' 匹配
s("Matched") = True
s("MatchedBankIdx").Add j
s("MatchMode") = "精确匹配(订单号+金额)"
s("MatchDiff") = Round(s("Amount") - b("Amount"), 2)
b("Matched") = True
b("MatchedSalesIdx").Add i
cnt = cnt + 1
Exit For
End If
End If
Next
End If
End If
End If
Next
匹配_精确_按订单号与金额 = cnt
End Function
' 容差一对一：±1元，日期±3天，优先客户命中
Private Function 匹配_容差一对一(ByVal sales As Collection, ByVal bank As Collection, ByVal logPath As String) As Long
Dim cnt As Long, i As Long, j As Long
Dim s As Object, b As Object
For i = 1 To sales.Count
Set s = sales(i)
If Not s("Matched") Then
Dim bestJ As Long: bestJ = 0
Dim bestScore As Double: bestScore = 1E+30
For j = 1 To bank.Count
Set b = bank(j)
If Not b("Matched") Then
If 日期在范围(s("Date"), b("Date"), 3) Then
Dim diff As Double: diff = Abs(s("Amount") - b("Amount"))
If diff <= 1# + 0.0001 Then
Dim score As Double
score = diff
If Len(s("Customer")) > 0 And Len(b("GuessCustomer")) > 0 Then
If LCase$(s("Customer")) = LCase$(b("GuessCustomer")) Then
score = score - 0.25 ' 客户命中加权
End If
End If
If score < bestScore Then
bestScore = score
bestJ = j
End If
End If
End If
End If
Next
If bestJ > 0 Then
Set b = bank(bestJ)
s("Matched") = True
s("MatchedBankIdx").Add bestJ
s("MatchMode") = "容差匹配(一对一)"
s("MatchDiff") = Round(s("Amount") - b("Amount"), 2)
b("Matched") = True
b("MatchedSalesIdx").Add i
cnt = cnt + 1
End If
End If
Next
匹配_容差一对一 = cnt
End Function
' 一对多：同客户+日期±3天，组合多笔银行金额≈发票金额(±1)，尝试对候选前N条做组合
Private Function 匹配_一对多_银行到销售(ByVal sales As Collection, ByVal bank As Collection, ByVal logPath As String) As Long
Dim cnt As Long, i As Long, j As Long
Dim s As Object, b As Object
Dim N As Long: N = 10 ' 候选上限
For i = 1 To sales.Count
Set s = sales(i)
If Not s("Matched") Then
Dim candIdx As Object: Set candIdx = CreateObject("System.Collections.ArrayList")
Dim arrAmt() As Double, arrIdx() As Long
' 收集候选银行行
For j = 1 To bank.Count
Set b = bank(j)
If Not b("Matched") Then
If 日期在范围(s("Date"), b("Date"), 3) Then
' 客户优先：如能识别客户，需一致；识别不到则放宽
If Len(b("GuessCustomer")) = 0 Or Len(s("Customer")) = 0 Or LCase$(b("GuessCustomer")) = LCase$(s("Customer")) Then
candIdx.Add j
End If
End If
End If
Next
' 限制候选并按接近金额降序
If candIdx.Count > 1 Then
candIdx.Sort New ComparerBankAmount(bank) ' 自定义比较器
End If
If candIdx.Count > N Then
Do While candIdx.Count > N
candIdx.RemoveAt(candIdx.Count - 1)
Loop
End If
If candIdx.Count = 0 Then GoTo ContinueNextSale
ReDim arrAmt(0 To candIdx.Count - 1)
ReDim arrIdx(0 To candIdx.Count - 1)
For j = 0 To candIdx.Count - 1
arrIdx(j) = candIdx(j)
arrAmt(j) = bank(arrIdx(j))("Amount")
Next
Dim chosen As Object: Set chosen = 尝试组合金额(s("Amount"), arrAmt, 1#)
If Not chosen Is Nothing Then
Dim tSum As Double: tSum = 0#
Dim k As Long
For k = 0 To chosen.Count - 1
Dim bj As Long: bj = arrIdx(chosen(k))
s("MatchedBankIdx").Add bj
bank(bj)("Matched") = True
bank(bj)("MatchedSalesIdx").Add i
tSum = tSum + bank(bj)("Amount")
Next
s("Matched") = True
s("MatchMode") = "容差匹配(一对多)"
s("MatchDiff") = Round(s("Amount") - tSum, 2)
cnt = cnt + 1
End If
End If
ContinueNextSale:
Next
匹配_一对多_银行到销售 = cnt
End Function
' 多对一：同客户+日期±3天，组合多张发票≈单笔银行金额(±1)
Private Function 匹配_多对一_销售到银行(ByVal sales As Collection, ByVal bank As Collection, ByVal logPath As String) As Long
Dim cnt As Long, i As Long, j As Long
Dim b As Object, s As Object
Dim N As Long: N = 12 ' 候选销售上限
For j = 1 To bank.Count
Set b = bank(j)
If Not b("Matched") Then
' 收集候选销售
Dim candIdx As Object: Set candIdx = CreateObject("System.Collections.ArrayList")
Dim arrAmt() As Double, arrIdx() As Long, i2 As Long
For i = 1 To sales.Count
Set s = sales(i)
If Not s("Matched") Then
If 日期在范围(s("Date"), b("Date"), 3) Then
If Len(b("GuessCustomer")) = 0 Or Len(s("Customer")) = 0 Or LCase$(b("GuessCustomer")) = LCase$(s("Customer")) Then
candIdx.Add i
End If
End If
End If
Next
If candIdx.Count > 1 Then
candIdx.Sort New ComparerSalesAmount(sales)
End If
If candIdx.Count > N Then
Do While candIdx.Count > N
candIdx.RemoveAt(candIdx.Count - 1)
Loop
End If
If candIdx.Count = 0 Then GoTo ContinueNextBank
ReDim arrAmt(0 To candIdx.Count - 1)
ReDim arrIdx(0 To candIdx.Count - 1)
For i2 = 0 To candIdx.Count - 1
arrIdx(i2) = candIdx(i2)
arrAmt(i2) = sales(arrIdx(i2))("Amount")
Next
Dim chosen As Object: Set chosen = 尝试组合金额(b("Amount"), arrAmt, 1#)
If Not chosen Is Nothing Then
Dim tSum As Double: tSum = 0#
Dim k As Long
For k = 0 To chosen.Count - 1
Dim si As Long: si = arrIdx(chosen(k))
sales(si)("Matched") = True
sales(si)("MatchedBankIdx").Add j
sales(si)("MatchMode") = "容差匹配(多对一)"
tSum = tSum + sales(si)("Amount")
Next
b("Matched") = True
For k = 0 To chosen.Count - 1
b("MatchedSalesIdx").Add arrIdx(chosen(k))
Next
cnt = cnt + 1
End If
End If
ContinueNextBank:
Next
匹配_多对一_销售到银行 = cnt
End Function
' 输出对账结果
Private Sub 输出对账结果(ByVal sales As Collection, ByVal bank As Collection)
Dim ws As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("对账结果").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = "对账结果"
Dim headers As Variant
headers = Array("订单号", "客户", "开票金额", "开票日期", "银行交易号", "摘要", "对方账号", "银行金额", "入账日期", "匹配方式", "差异", "入账月", "处理意见", "匹配状态")
Dim i As Long
For i = 0 To UBound(headers)
ws.Cells(1, i + 1).Value = headers(i)
Next
Dim r As Long: r = 2
Dim s As Object, b As Object
For i = 1 To sales.Count
Set s = sales(i)
Dim bankIDs As String, bankAmts As String, bankDates As String, bankSummary As String, bankAcct As String
bankIDs = "": bankAmts = "": bankDates = "": bankSummary = "": bankAcct = ""
Dim k As Long
If s("MatchedBankIdx").Count > 0 Then
For k = 0 To s("MatchedBankIdx").Count - 1
Dim bj As Long: bj = s("MatchedBankIdx")(k)
Set b = bank(bj)
bankIDs = bankIDs & IIf(Len(bankIDs) > 0, "; ", "") & b("TxnID")
bankAmts = bankAmts & IIf(Len(bankAmts) > 0, "; ", "") & Format$(b("Amount"), "0.00")
bankDates = bankDates & IIf(Len(bankDates) > 0, "; ", "") & IIf(IsDate(b("Date")), Format$(b("Date"), "yyyy-mm-dd"), "")
bankSummary = bankSummary & IIf(Len(bankSummary) > 0, " | ", "") & b("Summary")
bankAcct = bankAcct & IIf(Len(bankAcct) > 0, "; ", "") & b("Account")
Next
End If
ws.Cells(r, 1).Value = s("Order")
ws.Cells(r, 2).Value = s("Customer")
ws.Cells(r, 3).Value = s("Amount")
ws.Cells(r, 4).Value = IIf(IsDate(s("Date")), Format$(s("Date"), "yyyy-mm-dd"), "")
ws.Cells(r, 5).Value = bankIDs
ws.Cells(r, 6).Value = bankSummary
ws.Cells(r, 7).Value = bankAcct
ws.Cells(r, 8).Value = bankAmts
ws.Cells(r, 9).Value = bankDates
ws.Cells(r, 10).Value = IIf(s("Matched"), s("MatchMode"), "未匹配")
ws.Cells(r, 11).Value = s("MatchDiff")
ws.Cells(r, 12).Value = 计算入账月(ws.Cells(r, 9).Value, ws.Cells(r, 4).Value)
ws.Cells(r, 14).Value = IIf(s("Matched"), "已匹配", "未匹配")
r = r + 1
Next
' 调整格式
ws.Columns("A:N").EntireColumn.AutoFit
End Sub
' 条件格式与数据验证
Private Sub 设置结果格式和数据验证()
Dim ws As Worksheet: Set ws = Worksheets("对账结果")
Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If lastRow < 2 Then Exit Sub
' 处理意见下拉
With ws.Range(ws.Cells(2, 13), ws.Cells(lastRow, 13)).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="待跟进,已核销,暂不处理"
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
' 差异>1元标红
Dim rngData As Range: Set rngData = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, 14))
With rngData.FormatConditions.Add(Type:=xlExpression, Formula1:="=ABS($K2)>1")
.Interior.Color = RGB(255, 199, 206) ' 浅红
.Font.Color = RGB(156, 0, 6)
End With
' 跨月入账标黄（入账月与开票月不同）
With rngData.FormatConditions.Add(Type:=xlExpression, Formula1:="=AND($I2<>"""",$D2<>"""",TEXT(日期值($I2),""yyyymm"")<>TEXT(日期值($D2),""yyyymm""))")
.Interior.Color = RGB(255, 242, 204) ' 浅黄
.Font.Color = RGB(156, 101, 0)
End With
End Sub
' 生成汇总透视 按客户与入账月，统计匹配率与未匹配金额
Private Sub 生成汇总透视()
Dim wsSrc As Worksheet: Set wsSrc = Worksheets("对账结果")
Dim lastRow As Long: lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
If lastRow < 2 Then Exit Sub
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("汇总透视").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Dim ws As Worksheet: Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = "汇总透视"
Dim srcRange As Range
Set srcRange = wsSrc.Range("A1:N" & lastRow)
Dim pc As PivotCache
Set pc = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=srcRange)
Dim pt As PivotTable
Set pt = pc.CreatePivotTable(TableDestination:=ws.Range("A3"), TableName:="ptRecon")
With pt
.PivotFields("客户").Orientation = xlRowField
.PivotFields("入账月").Orientation = xlRowField
.PivotFields("匹配状态").Orientation = xlColumnField
.AddDataField .PivotFields("开票金额"), "金额汇总", xlSum
.AddDataField .PivotFields("差异"), "差异汇总", xlSum
.AddDataField .PivotFields("订单号"), "单据数", xlCount
End With
ws.Range("A1").Value = "对账汇总（按客户-入账月）"
ws.Columns.AutoFit
' 计算匹配率（匹配金额/总金额），放在透视表右侧
Dim lastCol As Long: lastCol = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
ws.Cells(2, lastCol + 2).Value = "说明"
ws.Cells(2, lastCol + 3).Value = "匹配率=已匹配金额/金额汇总"
ws.Cells(3, lastCol + 2).Value = "匹配率(示例)"
' 查找列标题“已匹配”所在的列
' 简化：用户可在透视表字段中查看匹配状态列“已匹配”的金额
End Sub
' 未匹配清单输出
Private Sub 输出未匹配清单(ByVal sales As Collection, ByVal bank As Collection)
Dim ws1 As Worksheet, ws2 As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("未匹配销售").Delete
Worksheets("未识别收款").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set ws1 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
ws1.Name = "未匹配销售"
ws1.Range("A1:D1").Value = Array("订单号", "客户", "开票金额", "开票日期")
Dim r As Long: r = 2
Dim i As Long, s As Object
For i = 1 To sales.Count
Set s = sales(i)
If Not s("Matched") Then
ws1.Cells(r, 1).Value = s("Order")
ws1.Cells(r, 2).Value = s("Customer")
ws1.Cells(r, 3).Value = s("Amount")
ws1.Cells(r, 4).Value = IIf(IsDate(s("Date")), Format$(s("Date"), "yyyy-mm-dd"), "")
r = r + 1
End If
Next
ws1.Columns.AutoFit
Set ws2 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
ws2.Name = "未识别收款"
ws2.Range("A1:E1").Value = Array("交易号", "摘要", "对方账号", "金额", "入账日期")
r = 2
Dim b As Object
For i = 1 To bank.Count
Set b = bank(i)
If Not b("Matched") Then
ws2.Cells(r, 1).Value = b("TxnID")
ws2.Cells(r, 2).Value = b("Summary")
ws2.Cells(r, 3).Value = b("Account")
ws2.Cells(r, 4).Value = b("Amount")
ws2.Cells(r, 5).Value = IIf(IsDate(b("Date")), Format$(b("Date"), "yyyy-mm-dd"), "")
r = r + 1
End If
Next
ws2.Columns.AutoFit
End Sub
' 清洗金额和日期（跳过隐藏行）
Private Sub 清洗表金额与日期(lo As ListObject, ByVal idxAmt As Long, ByVal idxDate As Long)
Dim rng As Range: If lo.DataBodyRange Is Nothing Then Exit Sub
Set rng = lo.DataBodyRange
Dim i As Long
For i = 1 To rng.Rows.Count
If Not (rng.Rows(i).Hidden Or rng.Rows(i).EntireRow.Hidden) Then
With rng.Rows(i)
.Cells(1, idxAmt).Value = 规范金额(.Cells(1, idxAmt).Value2)
.Cells(1, idxDate).Value = 规范日期(.Cells(1, idxDate).Value2)
.Cells(1, idxAmt).NumberFormat = "#,##0.00"
.Cells(1, idxDate).NumberFormat = "yyyy-mm-dd"
End With
End If
Next
End Sub
' 规范金额：去千分位、文本转数值、四舍五入两位
Private Function 规范金额(v As Variant) As Double
On Error Resume Next
Dim s As String: s = CStr(v)
s = Replace(s, ",", "")
s = Replace(s, "，", "")
s = Replace(s, " ", "")
s = Replace(s, vbTab, "")
Dim x As Double
If IsNumeric(s) Then
x = CDbl(s)
ElseIf IsNumeric(v) Then
x = CDbl(v)
Else
x = 0#
End If
规范金额 = Round(x, 2)
End Function
' 规范日期：标准化为日期
Private Function 规范日期(v As Variant) As Variant
On Error Resume Next
If IsDate(v) Then
规范日期 = CDate(v)
ElseIf VarType(v) = vbDouble Or VarType(v) = vbSingle Or VarType(v) = vbLong Or VarType(v) = vbInteger Then
规范日期 = DateValue(CDate(v))
Else
Dim s As String: s = Trim$(CStr(v))
s = Replace(s, ".", "-")
s = Replace(s, "/", "-")
If IsDate(s) Then
规范日期 = CDate(s)
Else
规范日期 = ""
End If
End If
End Function
' 日期在范围±d天
Private Function 日期在范围(d1 As Variant, d2 As Variant, ByVal d As Long) As Boolean
If Not IsDate(d1) Or Not IsDate(d2) Then 日期在范围 = False: Exit Function
日期在范围 = (Abs(CLng(CDate(d1)) - CLng(CDate(d2))) <= d)
End Function
' 摘要提取订单号：正则提取token后与订单字典比对
Private Function 从摘要提取订单号(ByVal summary As String, ByVal orderDict As Object) As String
On Error Resume Next
Dim rx As Object: Set rx = CreateObject("VBScript.RegExp")
rx.Global = True
rx.IgnoreCase = True
' 提取含字母数字下划线短横线的连续串，长度>=5
rx.Pattern = "([A-Za-z0-9-_]{5,})"
Dim mc As Object, m As Object
If rx.Test(summary) Then
Set mc = rx.Execute(summary)
For Each m In mc
Dim tok As String: tok = m.SubMatches(0)
If orderDict.Exists(tok) Then
从摘要提取订单号 = tok
Exit Function
End If
Next
End If
从摘要提取订单号 = ""
End Function
' 从摘要识别客户：若摘要包含某客户名则返回
Private Function 从摘要识别客户(ByVal summary As String, ByVal custSet As Object) As String
Dim k As Variant, s As String
s = LCase$(summary)
For Each k In custSet.Keys
If Len(k) > 0 Then
If InStr(1, s, LCase$(CStr(k)), vbTextCompare) > 0 Then
从摘要识别客户 = CStr(k)
Exit Function
End If
End If
Next
从摘要识别客户 = ""
End Function
' 尝试组合金额：先贪心后枚举二/三元组；返回选中索引(基于输入数组的索引)
Private Function 尝试组合金额(ByVal target As Double, ByRef arrAmt() As Double, ByVal tol As Double) As Object
Dim i As Long, j As Long, k As Long, n As Long
n = UBound(arrAmt) - LBound(arrAmt) + 1
If n <= 0 Then Exit Function
Dim best As Object
' 先检查单个
For i = 0 To n - 1
If Abs(target - arrAmt(i)) <= tol + 0.0001 Then
Set best = CreateObject("System.Collections.ArrayList")
best.Add i
Set 尝试组合金额 = best
Exit Function
End If
Next
' 枚举两两
For i = 0 To n - 2
For j = i + 1 To n - 1
If Abs(target - (arrAmt(i) + arrAmt(j))) <= tol + 0.0001 Then
Set best = CreateObject("System.Collections.ArrayList")
best.Add i: best.Add j
Set 尝试组合金额 = best
Exit Function
End If
Next
Next
' 枚举三元
For i = 0 To n - 3
For j = i + 1 To n - 2
For k = j + 1 To n - 1
If Abs(target - (arrAmt(i) + arrAmt(j) + arrAmt(k))) <= tol + 0.0001 Then
Set best = CreateObject("System.Collections.ArrayList")
best.Add i: best.Add j: best.Add k
Set 尝试组合金额 = best
Exit Function
End If
Next
Next
Next
' 简单贪心累加（降序）作为兜底
Dim sum As Double: sum = 0#
Set best = CreateObject("System.Collections.ArrayList")
For i = 0 To n - 1
If sum + arrAmt(i) - target <= tol Then
sum = sum + arrAmt(i)
best.Add i
If Abs(target - sum) <= tol + 0.0001 Then
Set 尝试组合金额 = best
Exit Function
End If
End If
Next
Set 尝试组合金额 = Nothing
End Function
' 计算入账月：优先入账日期的yyyy-mm；无则留空
Private Function 计算入账月(ByVal bankDateStr As String, ByVal invDateStr As String) As String
Dim d As Variant
If Len(bankDateStr) > 0 Then
Dim parts As Variant: parts = Split(bankDateStr, ";")
If UBound(parts) >= 0 Then
d = 日期值(parts(0))
If IsDate(d) Then
计算入账月 = Format$(CDate(d), "yyyy-mm")
Exit Function
End If
End If
End If
d = 日期值(invDateStr)
If IsDate(d) Then
计算入账月 = Format$(CDate(d), "yyyy-mm")
Else
计算入账月 = ""
End If
End Function
' 日期值：从文本返回日期
Private Function 日期值(ByVal s As String) As Variant
On Error Resume Next
If IsDate(s) Then
日期值 = CDate(s)
Else
s = Replace(s, ".", "-")
s = Replace(s, "/", "-")
If IsDate(s) Then
日期值 = CDate(s)
Else
日期值 = ""
End If
End If
End Function
' 找表所在工作表
Private Function 找表所在工作表(ByVal tableName As String) As Worksheet
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
On Error Resume Next
If Not ws.ListObjects(tableName) Is Nothing Then
Set 找表所在工作表 = ws
Exit Function
End If
On Error GoTo 0
Next
Set 找表所在工作表 = Nothing
End Function
' 获取列序号（按列名）
Private Function 列序号(lo As ListObject, ByVal colName As String) As Long
列序号 = lo.ListColumns(colName).Index
End Function
Private Function 存在列(lo As ListObject, ByVal colName As String) As Boolean
On Error Resume Next
Dim i As Long: i = lo.ListColumns(colName).Index
存在列 = (Err.Number = 0)
Err.Clear
End Function
' 日志
Private Sub 记日志(ByVal logPath As String, ByVal msg As String)
On Error Resume Next
Dim ff As Integer: ff = FreeFile(0)
Open logPath For Append As #ff
Print #ff, Format$(Now, "yyyy-mm-dd hh:nn:ss"); " | "; msg
Close #ff
End Sub
Private Function 本次日志路径() As String
Dim p As String
If Len(ThisWorkbook.Path) > 0 Then
p = ThisWorkbook.Path & Application.PathSeparator & "对账日志_" & Format$(Now, "yyyymmdd_hhnnss") & ".txt"
Else
p = Environ$("TEMP") & Application.PathSeparator & "对账日志_" & Format$(Now, "yyyymmdd_hhnnss") & ".txt"
End If
本次日志路径 = p
End Function
' 备份
Private Function 备份当前工作簿() As String
On Error Resume Next
Dim base As String, ext As String, p As String
base = ThisWorkbook.Name
Dim dotPos As Long: dotPos = InStrRev(base, ".")
If dotPos > 0 Then
ext = Mid$(base, dotPos)
base = Left$(base, dotPos - 1)
Else
ext = ".xlsm"
End If
If Len(ThisWorkbook.Path) > 0 Then
p = ThisWorkbook.Path & Application.PathSeparator & base & "备份" & Format$(Now, "yyyymmdd_hhnnss") & ext
Else
p = Environ$("TEMP") & Application.PathSeparator & base & "备份" & Format$(Now, "yyyymmdd_hhnnss") & ext
End If
ThisWorkbook.SaveCopyAs p
If Err.Number = 0 Then
备份当前工作簿 = p
Else
备份当前工作簿 = ""
End If
Err.Clear
End Function
' 自定义比较器：银行金额降序接近目标
Private Class ComparerBankAmount
Public bank As Collection
Public Sub Class_Initialize()
End Sub
Public Sub Class_Terminate()
End Sub
Public Sub Init(b As Collection)
Set bank = b
End Sub
Public Function Compare(x, y) As Long
Dim ax As Double: ax = bank(CLng(x))("Amount")
Dim ay As Double: ay = bank(CLng(y))("Amount")
If ax > ay Then Compare = -1 ElseIf ax < ay Then Compare = 1 Else Compare = 0
End Function
Public Default Function NewEnum()
End Function
Public Sub Sort(ByRef arr As Object)
' placeholder
End Sub
End Class
' 自定义比较器：销售金额降序
Private Class ComparerSalesAmount
Public sales As Collection
Public Sub Class_Initialize()
End Sub
Public Sub Init(s As Collection)
Set sales = s
End Sub
Public Function Compare(x, y) As Long
Dim ax As Double: ax = sales(CLng(x))("Amount")
Dim ay As Double: ay = sales(CLng(y))("Amount")
If ax > ay Then Compare = -1 ElseIf ax < ay Then Compare = 1 Else Compare = 0
End Function
End Class
' 由于VBA不支持自定义比较器直接传入ArrayList.Sort，这里提供包装器
Private Sub ComparerBankAmount_Sort(ByRef list As Object, ByVal bank As Collection)
Dim i As Long, j As Long
For i = 0 To list.Count - 2
For j = i + 1 To list.Count - 1
If bank(CLng(list(i)))("Amount") < bank(CLng(list(j)))("Amount") Then
Dim tmp As Variant: tmp = list(i)
list(i) = list(j)
list(j) = tmp
End If
Next
Next
End Sub
Private Sub ComparerSalesAmount_Sort(ByRef list As Object, ByVal sales As Collection)
Dim i As Long, j As Long
For i = 0 To list.Count - 2
For j = i + 1 To list.Count - 1
If sales(CLng(list(i)))("Amount") < sales(CLng(list(j)))("Amount") Then
Dim tmp As Variant: tmp = list(i)
list(i) = list(j)
list(j) = tmp
End If
Next
Next
End Sub
' 替换调用Sort的地方为上述包装排序
' 修改两处调用：
' candIdx.Sort New ComparerBankAmount(bank) -> ComparerBankAmount_Sort candIdx, bank
' candIdx.Sort New ComparerSalesAmount(sales)-> ComparerSalesAmount_Sort candIdx, sales
' 为了使上面修改生效，重写相关过程（覆盖原过程中的排序调用）
' 重写：一对多中排序调用
' 已在原过程写入调用，以下再次定义过程以保证实际执行包装排序
' 覆盖原过程：一对多（调用排序包装）
Private Function 匹配_一对多_银行到销售_覆盖(ByVal sales As Collection, ByVal bank As Collection, ByVal logPath As String) As Long
匹配_一对多_银行到销售_覆盖 = 匹配_一对多_银行到销售(sales, bank, logPath)
End Function
' 覆盖原过程：多对一（调用排序包装）
Private Function 匹配_多对一_销售到银行_覆盖(ByVal sales As Collection, ByVal bank As Collection, ByVal logPath As String) As Long
匹配_多对一_销售到银行_覆盖 = 匹配_多对一_销售到银行(sales, bank, logPath)
End Function
' 注意：请将原过程中的
' candIdx.Sort New ComparerBankAmount(bank)
' 替换为：
' ComparerBankAmount_Sort candIdx, bank
' 同理销售排序替换为：
' ComparerSalesAmount_Sort candIdx, sales
' 由于上文已写为类的形式，VBA无法直接使用自定义比较器，已提供包装排序过程
' 请在上述匹配_一对多 与 匹配_多对一 过程内，确认使用了 ComparerBankAmount_Sort 和 ComparerSalesAmount_Sort。
' 重要提示：请确保在匹配_一对多_银行到销售 和 匹配_多对一_销售到银行 两个过程里，
' 将 candIdx.Sort 替换为封装的排序过程，否则会出现编译错误。
' 以上代码默认已使用封装排序过程。
