VBA-⾃动对账（改善版）仅供参考
1.在⼯作表的open事件中添加代码，⽤以提醒⽤户使⽤规则
Private Sub Workbook_Open()
If MsgBox("该⼯作表仅⽀持快递对账费⽤，如不是快递费⽤对账请关闭", vbYesNo, "温馨提⽰") = vbYes Then
Dim w0 As Workbook
Dim book1 As Worksheet
Dim book2 As Worksheet
Set w0 = ActiveWorkbook
Set book1 = w0.Worksheets("sheet1")
Set book2 = w0.Worksheets("sheet2")
book1.UsedRange.Cells.Clear
book2.UsedRange.Cells.Clear
MsgBox "请复制需要处理的运费明细，要求源格式粘贴", vbOKOnly, "请按要求执⾏"
End If
End Sub
2.在模块中写三个⼩功能来实现整体的⾃动对账功能（这⾥没有使⽤全局变量，是为了后期可以将代码直接复制到其他功能中，在实际⼯作中，看实际⼯作中的需求情况可以设置全局变量），代码如下：
Option Explicit
Sub ⾃动核对()
Call 复制
Call cfreetest
Call 核对
End Sub
Sub 核对()
Dim i As Long
Dim j As Long
Dim w0 As Workbook
Set w0 = ActiveWorkbook
Dim b1 As Worksheet
Dim b2  As Worksheet
Set b1 = w0.Worksheets("Sheet1")
Set b2 = w0.Worksheets("Sheet2")
Dim r0 As Range
Dim r1 As Range
Dim r2 As Range
Set r1 = b1.UsedRange
Set r2 = b2.UsedRange
Dim p1()
Dim p2()
p1 = r1
p2 = r2
Dim count0 As Integer
count0 = 0
For j = 1 To r1.Rows.Count - 1
For i = 8 To r2.Columns.Count - 1
If p1(j, i) <> p2(j, i) Then
If r1.Resize(1, 1).Offset(j - 1, 0).Interior.Color <> vbRed Then
r1.Resize(1, r2.Columns.Count).Offset(j - 1, 0).Interior.Color = vbRed
r1.Resize(1, 1).Offset(j - 1, i - 1).Interior.Color = vbGreen
r2.Resize(1, r2.Columns.Count).Offset(j - 1, 0).Interior.Color = vbRed
r2.Resize(1, 1).Offset(j - 1, i - 1).Interior.Color = vbGreen
count0 = count0 + 1
Else
r1.Resize(1, 1).Offset(j - 1, i - 1).Interior.Color = vbGreen
r1.Resize(1, 1).Offset(j - 1, i - 1).Interior.Color = vbGreen
r2.Resize(1, 1).Offset(j - 1, i - 1).Interior.Color = vbGreen
End If
End If
Next i
Next j
If count0 > 0 Then
MsgBox "已完成核对，共" & count0 & "条数据有误，请耐⼼核对" Else
MsgBox "已完成核对，数据⽆误，可打印审核。"
End If
End Sub
Sub cfreetest()
Dim i  As Integer
i = 1
Dim j As Long
'定义对象来承接⽬标值
Dim Ttype As Range
Dim l1 As Range
Dim l2 As Range
Dim wight As Range
Dim cf As Range
Dim load As String
Dim cfree() As Double
'获取需要的数据
Dim w0 As Workbook
Set w0 = ActiveWorkbook
Dim r0 As Range
Dim w As Workbook
Dim book0 As Worksheet
Set book0 = w0.Worksheets("Sheet2")
Set r0 = book0.UsedRange.Resize(book0.UsedRange.Rows.Count - 1, 1) Do While book0.UsedRange.Cells(1, i) <> ""
If book0.UsedRange.Cells(1, i) = "计费类型" Then
Set Ttype = r0.Offset(1, i - 1)
ElseIf book0.UsedRange.Cells(1, i) = "起运地" Then
Set l1 = r0.Offset(1, i - 1)
ElseIf book0.UsedRange.Cells(1, i) = "⽬的地" Then
Set l2 = r0.Offset(1, i - 1)
ElseIf book0.UsedRange.Cells(1, i) = "计费重量" Then
Set wight = r0.Offset(1, i - 1)
ElseIf book0.UsedRange.Cells(1, i) = "运费" Then
Set cf = r0.Offset(1, i - 1)
End If
i = i + 1
Loop
ReDim cfree(1 To Ttype.Rows.Count, 1 To 1)
'将报价表信息读⼊数组
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim book1()
Dim book2()
Dim book3()
Dim mp As String
mp = ActiveWorkbook.Path
Set w = Workbooks.Open(mp & "\价格⼀览表.xlsm")
'将价格表信息获取到数组⾥
Set r1 = w.Worksheets("type1").UsedRange
Set r2 = w.Worksheets("type2").UsedRange
Set r3 = w.Worksheets("type3").UsedRange
Set r3 = w.Worksheets("type3").UsedRange
Dim price()
'循环到对应的报价信息并计算运费
For i = 1 To l1.Rows.Count
j = 1
load = l1(i, 1) & l2(i, 1)
If Ttype(i, 1) = "type1" Then
price = r1
'出对应的运输路线
Do While j < UBound(price())
If price(j, 1) & price(j, 2) = load Then Exit Do
j = j + 1
Loop
If wight(i, 1) <= 5 Then
cfree(i, 1) = wight(i, 1) * price(j, 3)
ElseIf wight(i, 1) <= 10 Then
cfree(i, 1) = (wight(i, 1) - 5) * price(j, 4) + 5 * price(j, 3)
ElseIf wight(i, 1) <= 20 Then
cfree(i, 1) = (wight(i, 1) - 10) * price(j, 5) + 5 * price(j, 4) + 5 * price(j, 3)
Else
cfree(i, 1) = (wight(i, 1) - 20) * price(j, 6) + 10 * price(j, 5) + 5 * price(j, 4) + 5 * price(j, 3)          End If
ElseIf Ttype(i, 1) = "type2" Thenresize函数vba
price = r2
'出对应的运输路线
Do While j < UBound(price())
If price(j, 1) & price(j, 2) = load Then Exit Do
j = j + 1
Loop
If wight(i, 1) <= 1 Then
cfree(i, 1) = wight(i, 1) * price(j, 3)
ElseIf wight(i, 1) <= 5 Then
cfree(i, 1) = (wight(i, 1) - 1) * price(j, 4) + 1 * price(j, 3)
ElseIf wight(i, 1) <= 10 Then
cfree(i, 1) = (wight(i, 1) - 5) * price(j, 5) + 4 * price(j, 4) + 1 * price(j, 3)
Else
cfree(i, 1) = (wight(i, 1) - 10) * price(j, 6) + 5 * price(j, 5) + 4 * price(j, 4) + 1 * price(j, 3)
End If
ElseIf Ttype(i, 1) = "type3" Then
price = r3
'出对应的运输路线
Do While j < UBound(price())
If price(j, 1) & price(j, 2) = load Then Exit Do
j = j + 1
Loop
If wight(i, 1) <= 10 Then
cfree(i, 1) = wight(i, 1) * price(j, 3)
ElseIf wight(i, 1) <= 20 Then
cfree(i, 1) = (wight(i, 1) - 10) * price(j, 4) + 10 * price(j, 3)
ElseIf wight(i, 1) <= 50 Then
cfree(i, 1) = (wight(i, 1) - 20) * price(j, 5) + 10 * price(j, 4) + 10 * price(j, 3)
Else
cfree(i, 1) = (wight(i, 1) - 50) * price(j, 6) + 30 * price(j, 5) + 10 * price(j, 4) + 10 * price(j, 3)          End If
Else
End If
End If
Next i
cf = cfree
w.Close
End Sub
Sub 复制()
'将要核对的表格复制到计算表格⾥，⽅便后续核对，将需要计算的运费和其他费⽤进⾏清空，⽅便后续计算Dim w As Workbook
Dim mp As String
Set w = ActiveWorkbook
'Set w = Workbooks.Open(mp & "\ 费⽤计算和类⽐.xlsm")
Dim book1 As Worksheet
Dim book2 As Worksheet
Dim rleth As Integer
Dim cleth As Integer
Dim r1 As Range
Dim r2 As Range
Set book1 = w.Worksheets(1)
Set book2 = w.Worksheets(2)
'到运费⼀栏
For Each r1 In book1.UsedRange
If r1.Value = "运费" Then
rleth = r1.Row
cleth = r1.Column
End If
Next r1
Set r1 = book1.UsedRange
r1.Select
Selection.Copy
book2.Select
Cells(r1.Row, r1.Column).Select
ActiveSheet.Paste
'将运费⼀栏的数据清空
Set r1 = book2.UsedRange(2, cleth)
Set r2 = r1.Resize(book2.UsedRange.Rows.Count - 1, book2.UsedRange.Columns.Count - cleth)
r2.Value = ""
End Sub
以上，谢谢!

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。