假設 表壹 為"A表"? 表二為?"B表"，自動添加2個輔助列，不同金額分別在兩個表相應的位置成對標為1，2，3，。。。。 直到所有的A表數據與B表核對完成。代碼放在 ThisWorkbook 或”模塊“中
Sub 對比數據()
ThisWorkbook.Activate
Dim shtA As Object, shtB As Object
Dim rngCLA As Range, rngCLB As Range
Dim rngA&, rngB&
Dim aryCheckA(1 To 4) As String
Dim strCheck$
Dim i%, j%, k%
Set shtA = Sheets("A表")
Set shtB = Sheets("B表")
k = 0
For i = 1 To 2
If i = 1 Then shtA.Activate Else shtB.Activate
Columns("A:B").Insert
For Each rngCLA In Range(Cells(1, 3), Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column))
If rngCLA.Value = "進口國" Then
aryCheckA(1) = rngCLA.Address(0, 0)
ElseIf rngCLA.Value = "出口國" Then aryCheckA(2) = rngCLA.Address(0, 0)
ElseIf rngCLA.Value = "年份" Then aryCheckA(3) = rngCLA.Address(0, 0)
ElseIf rngCLA.Value = "金額" Then aryCheckA(4) = rngCLA.Address(0, 0)
End If
Next
Set rngCLA = Nothing
For j = 1 To 3
strCheck = strCheck & aryCheckA(j) & "&"
Next
If i = 1 Then rngA = Range(aryCheckA(4)).Column Else rngB = Range(aryCheckA(4)).Column
Cells(1, 2).Formula = "=" & Left(strCheck, Len(strCheck) - 1)
Cells(1, 2).Copy
Range(Cells(1, 2), Cells(Cells(Rows.Count, 3).End(xlUp).Row, 2)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial xlPasteValues
strCheck = ""
Next
For Each rngCLA In Range(shtA.Cells(2, 2), shtA.Cells(shtA.Cells(Rows.Count, 3).End(xlUp).Row, 2))
For Each rngCLB In Range(shtB.Cells(2, 2), shtB.Cells(shtB.Cells(Rows.Count, 3).End(xlUp).Row, 2))
If rngCLA.Value = rngCLB.Value Then
If shtA.Cells(rngCLA.Row, rngA).Value <> shtB.Cells(rngCLB.Row, rngB).Value Then k = k + 1: shtA.Cells(rngCLA.Row, 1).Value = k: shtB.Cells(rngCLB.Row, 1).Value = k
Exit For
End If
Next
Next
Set rngCLA = Nothing
Set rngCLB = Nothing
End Sub