Option Explicit
Sub IAmJohnSmithAndMyFriendIsJamesJones()
'
' constants
' files
Const ksWS1 = "Hoja1"
Const ksData1 = "DataTable"
Const ksWB2 = "Compare multiple columns between files - 2 (for Ronald Wilson at chandoo.org).xlsm"
Const ksWS2 = "Hoja1"
Const ksData2 = "DataTable"
Const ksSummary = "Summary"
Const ksSortKeys = "@,A,B,C"
' texts
Const ksComma = ","
Const ksColon = ":"
Const ksSeparator = "_"
Const ksEOF = "zzz"
Const ksAdded = "Added"
Const ksUpdated = "Updated"
Const ksDeleted = "Deleted"
'
' declarations
Dim rng(2) As Range
Dim iSummary(2) As Integer, lIndex(2) As Long, sString(2) As String
Dim vSortKeys As Variant
Dim I As Long, J As Integer
'
' start
' 2nd workbook
With Workbooks
For I = 1 To .Count
If Workbooks(I).Name = ksWB2 Then Exit For
Next I
If I > .Count Then
.Open ActiveWorkbook.Path & Application.PathSeparator & ksWB2
ThisWorkbook.Activate
End If
End With
' ranges
Set rng(1) = ActiveWorkbook.Worksheets(ksWS1).Range(ksData1)
Set rng(2) = Workbooks(ksWB2).Worksheets(ksWS2).Range(ksData2)
If rng(1) Is Nothing Or rng(2) Is Nothing Then GoTo IAmJohnSmithAndMyFriendIsJamesJones_Exit
' application
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
' initialize
For I = 1 To 2
With rng(I)
For J = 1 To .Columns.Count
If .Cells(0, J).Value = ksSummary Then Exit For
Next J
If J > .Columns.Count Then
.Cells(0, J).Value = ksSummary
Set rng(I) = .Resize(.Rows.Count, .Columns.Count + 1)
End If
iSummary(I) = J
Range(.Cells(1, iSummary(I)), .Cells(.Rows.Count, iSummary(I))).ClearContents
End With
Next I
' keys
vSortKeys = Split(ksSortKeys, ksComma)
'
' process
' sort, if not
For I = 1 To 2
With rng(I)
With .Parent.Sort
With .SortFields
.Clear
For J = 1 To UBound(vSortKeys)
.Add Key:=Range(vSortKeys(J) & ksColon & vSortKeys(J)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Next J
End With
.SetRange rng(I).Parent.Cells
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Cells(1, 1).Select
End With
Workbooks(ksWB2).Activate
Next I
ThisWorkbook.Activate
' cycle
lIndex(1) = 1
lIndex(2) = 1
Do Until lIndex(1) > rng(1).Rows.Count And lIndex(2) > rng(2).Rows.Count
' build control strings
For I = 1 To 2
With rng(I)
If lIndex(I) <= .Rows.Count Then
sString(I) = .Cells(lIndex(I), 1).Value & ksSeparator & _
.Cells(lIndex(I), 2).Value & ksSeparator & _
.Cells(lIndex(I), 3).Value & ksSeparator
Else
sString(I) = ksEOF
End If
End With
Next I
' compare
Select Case sString(1)
Case Is < sString(2)
rng(1).Cells(lIndex(1), iSummary(1)).Value = ksDeleted
lIndex(1) = lIndex(1) + 1
Case Is = sString(2)
For I = 1 To rng(1).Columns.Count - 1
If rng(1).Cells(lIndex(1), I).Value <> rng(2).Cells(lIndex(2), I).Value Then
rng(1).Cells(lIndex(1), iSummary(1)).Value = ksUpdated
rng(2).Cells(lIndex(2), iSummary(2)).Value = ksUpdated
Exit For
End If
Next I
lIndex(1) = lIndex(1) + 1
lIndex(2) = lIndex(2) + 1
Case Is > sString(2)
rng(2).Cells(lIndex(2), iSummary(2)).Value = ksAdded
lIndex(2) = lIndex(2) + 1
End Select
Loop
'
' end
' application
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
IAmJohnSmithAndMyFriendIsJamesJones_Exit:
' ranges
Set rng(2) = Nothing
Set rng(1) = Nothing
Beep
'
End Sub
