Hello Kartyk,
Here is the updated code. The macro now searches each sheet for the location of the headers "Account", "Lots", and "Rate" in row . Case is ignored and whole words are matched. If the headers are different on the worksheet then the macro will need to be changed to use the new headers.
Updated Code:
Option Explicit
Global Dict1 As Object
Global Dict2 As Object
Function LoadDict(ByRef objDict As Object, ByRef Wks As Worksheet)
Dim Cell As Range
Dim cxLots As Long
Dim cxRate As Long
Dim Dict As Object
Dim Key As Variant
Dim n As Double
Dim rngAcct As Range
Dim rngBeg As Range
Dim rngEnd As Range
Dim rngLots As Range
Dim rngRate As Range
With Wks.Range("1:1")
Set rngAcct = .Find("Account", , xlValues, xlWhole, xlByColumns, xlNext, False, False, False)
Set rngLots = .Find("Lots"): cxLots = rngLots.Column - rngAcct.Column
Set rngRate = .Find("Rate"): cxRate = rngRate.Column - rngAcct.Column
End With
If objDict Is Nothing Then
Set objDict = CreateObject("Scripting.Dictionary")
objDict.CompareMode = vbTextCompare
Else
objDict.RemoveAll
End If
Set rngBeg = rngAcct.Offset(1, 0)
Set rngEnd = Wks.Cells(Rows.Count, rngBeg.Column).End(xlUp)
If rngEnd.Row < rngBeg.Row Then Exit Function
For Each Cell In Wks.Range(rngBeg, rngEnd)
Key = Trim(Cell)
If Key <> "" Then
Key = Key & "_" & Cell.Offset(0, cxRate).Value ' Account & Rate
If Not objDict.Exists(Key) Then
objDict.Add Key, Cell.Offset(0, cxLots).Value ' Lots
Else
' Sum the Lots
n = objDict(Key)
objDict(Key) = n + Cell.Offset(0, cxLots).Value
End If
End If
Next Cell
Set LoadDict = Wks.Range(rngBeg, rngEnd)
End Function
Sub CompareData()
Dim Cell As Range
Dim j As Long
Dim k As Long
Dim Key As String
Dim colEnd As Long
Dim Rng As Variant
Dim Rng1 As Range
Dim Rng2 As Range
Dim rngBeg As Range
Dim rngEnd As Range
Dim Wkb1 As Workbook
Dim Wkb2 As Workbook
Dim Wks1 As Worksheet
Dim Wks2 As Worksheet
Set Wkb1 = ThisWorkbook
Set Wks1 = Wkb1.Worksheets("Excel 1")
' Change this workbook to the match the second open workbook.
Set Wkb2 = ThisWorkbook 'Workbooks(2)
Set Wks2 = Wkb2.Worksheets("Excel 2")
Application.ScreenUpdating = False
Set Rng1 = LoadDict(Dict1, Wks1)
Set Rng2 = LoadDict(Dict2, Wks2)
For Each Rng In Array(Rng1, Rng2)
colEnd = Rng.Parent.Cells(1, Columns.Count).End(xlToLeft).Column + 1
For Each Cell In Rng.Cells
Key = Trim(Cell.Value)
If Key <> "" Then
Key = Cell & "_" & Cell.Offset(0, -1).Value
If Dict1(Key) = Dict2(Key) Then
Cell.Offset(0, colEnd - Cell.Column).Value = "Pass"
Else
Cell.Offset(0, colEnd - Cell.Column).Value = "Fail"
End If
End If
Next Cell
Next Rng
Application.ScreenUpdating = True
End Sub
Reply With Quote
