How to compare data on differerent excel spreadsheets

hchristian · Aug 12, 2011

Dear Forum Members:

I use Excel 2007.

I research government records and compile Excel lists of dormant assets. I also receive lists of dormant assets from government agencies in Excel, often 25,000 lines or more.

I maintain a client list in Excel.

I then manually sort and review each Excel spreadsheet and manually compare it to my list of clients to identify potential recoveries. Very time consuming and lots of margin for error. Recent clients have hundreds of subsidiaries making this task nearly impossible.

I would like to automate this process (perhaps a macro) so that I can query individual Excel spreadsheet of dormant assets against my list of existing clients – and extrapolate those which match into a new spreadsheet.

The query needs to be a bit "fuzzy" to return matches, as the name is not always precise on the government lists. "A. B. Jones Asphalt" on my client list may be listed as "Jones Asphalt, A B" on the government list.

Any assistance would be a blessing! Thank you in advance.

al_b_cnu · Aug 19, 2011

Hi, Welcome to the board

One of he most efficient approaches may be to 'Normalise' the company name and then store it as a key in a Dictionary object.

By 'Normalise' I mean convert to uppercase, replace all non alphanumerics with spaces and then remove multiple spaces
So 'A.B. Jones Asphalt' would be stored as 'A B JONES ASPHALT' (which comprises 4 'words')

for the matching process we can then normalise each dormant asset name and then try to match each word permutation against our dictionary object. So, the code would try to match all 24 combinations of 'A' 'B' 'JONES' and 'ASPHALT' against the dictionary (or until it found a match).

Sounds easy eh?

That said, an 8-word name would generate over 40,000 permutations for the code to check :¬/

I would need data layouts of each of the spreadsheet before writing the macro of course.

al_b_cnu · Aug 19, 2011

Perhaps a neater (& quicker) twist to this would be to just sort the words alphabetically before comparing, so, for example, it would store the name 'A.B'Jones, Asphalt' as 'A ASHPHALT B JONES'. No need for Permutations processing then.

al_b_cnu · Aug 19, 2011

Hi, Try this 'GetDormantAssets' macro:

Code:

Option Explicit
Const msExistingSheetName As String = "Sheet1"
Const msExistingNameColumn As String = "A"

Const msDormantSheetName As String = "Sheet1"
Const msDormantNameColumn As String = "A"

Const msResultsSheetName As String = "Sheet3"

Const mlExistingStartDataRow As Long = 2
Const mlDormantStartDataRow As Long = 2

Sub GetDormantAssets()
Dim bError As Boolean
Dim lRow As Long
Dim lResultsRow As Long
Dim objNamesDictionary As Object
Dim rCur As Range
Dim sCurName As String
Dim vFile As Variant
Dim wbDormant As Workbook
Dim wsDormant As Worksheet
Dim wsExisting As Worksheet
Dim wsResults As Worksheet

bError = False
Set wsExisting = Nothing
On Error Resume Next
Set wsExisting = ThisWorkbook.Sheets(msExistingSheetName)
On Error GoTo 0
If wsExisting Is Nothing Then
    MsgBox prompt:="Error accessing sheet '" & msExistingSheetName & "'" & vbCrLf & Err.Description, _
            Buttons:=vbOKOnly + vbCritical
    bError = True
End If

If bError = False Then
    vFile = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*), *.xls*", _
                                      Title:="Please select Input Dormant File to be searched")
    If vFile = False Then
        MsgBox prompt:="Macro abandoned at user request", _
                Buttons:=vbOKOnly + vbInformation
        bError = True
    End If
End If

If bError = False Then
    Set wbDormant = Nothing
    On Error Resume Next
    Set wbDormant = Workbooks.Open(Filename:=vFile, ReadOnly:=True)
    On Error GoTo 0
    If wbDormant Is Nothing Then
        MsgBox prompt:="Unable to open file:" & vbCrLf & CStr(vFile) & vbCrLf & Err.Description, _
                Buttons:=vbCritical + vbOKOnly, _
                Title:="Error opening Dormant File"
        bError = True
    Else
        Set wsDormant = Nothing
        On Error Resume Next
        Set wsDormant = wbDormant.Sheets(msDormantSheetName)
        On Error GoTo 0
        If wsDormant Is Nothing Then
            MsgBox prompt:="Unable to open sheet '" & msDormantSheetName & "' from Dormant file" & vbCrLf & _
                            Err.Description, _
                    Buttons:=vbOKOnly + vbCritical, _
                    Title:="Error accessing Dormant file sheet"
            bError = True
        End If
    End If
End If

'-- Set up Names Dictionary  --
If bError = False Then
    
    Set objNamesDictionary = Nothing
    Set objNamesDictionary = CreateObject("Scripting.Dictionary")
    
    lRow = wsExisting.Cells(Rows.Count, msExistingNameColumn).End(xlUp).Row
    If lRow > 1 Then
        For Each rCur In wsExisting.Range(msExistingNameColumn & "2:" & msExistingNameColumn & lRow)
            sCurName = CStr(rCur.Value)
            On Error Resume Next
            objNamesDictionary.Add Key:=NormaliseName(sCurName), Item:=sCurName
            On Error GoTo 0
        Next rCur
    End If
    
End If

If bError = False Then
    Set wsResults = ThisWorkbook.Sheets(msResultsSheetName)
    wsResults.UsedRange.ClearContents
    wsResults.Range("A1").Value = "Name"
    lResultsRow = 1
    
    lRow = wsDormant.Cells(Rows.Count, msDormantNameColumn).End(xlUp).Row
    If lRow > 1 Then
        For Each rCur In wsDormant.Range(msDormantNameColumn & "2:" & msDormantNameColumn & lRow)
            sCurName = Trim$(CStr(rCur.Value))
            If sCurName <> "" Then
                If objNamesDictionary.exists(NormaliseName(sCurName)) Then
                    lResultsRow = lResultsRow + 1
                    wsResults.Cells(lResultsRow, 1).Value = sCurName
                End If
            End If
        Next rCur
    End If
End If

On Error Resume Next
objNamesDictionary.RemoveAll
Set objNamesDictionary = Nothing
wbDormant.Close

End Sub

Function NormaliseName(ByVal Stringx As String) As String
Dim lPtr As Long, lPtr1 As Long
Dim sCur As String, sResult As String
Dim saResult() As String

'-- replace anything other than A to Z, 0 to 9 or apostrophe with a space, and convert to uppercase
sResult = Stringx
For lPtr = 1 To Len(sResult)
    sCur = UCase$(Mid$(sResult, lPtr, 1))
    If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZ'0123456789", sCur) = 0 Then sCur = " "
    Mid$(sResult, lPtr, 1) = sCur
Next lPtr

sResult = WorksheetFunction.Trim(Stringx)       ' remove leading, trailing & intermediate multiple spaces

'-- Now sort the result --
If sResult <> "" Then
    saResult = Split(WorksheetFunction.Trim(sResult), " ")
    For lPtr = 0 To UBound(saResult) - 1
        sCur = saResult(lPtr)
        For lPtr1 = lPtr + 1 To UBound(saResult)
            
            If sCur > saResult(lPtr1) Then
                saResult(lPtr) = saResult(lPtr1)
                saResult(lPtr1) = sCur
                sCur = saResult(lPtr)
            End If
        Next lPtr1
    Next lPtr
    sResult = Join(saResult, " ")
End If

NormaliseName = sResult
End Function

The macro assumes that the names in both the Existing Client list & dormant file are in Sheet1, column A, and start in row 2
You are prompted for the input Dormant file, and the output is placed in sheet3

al_b_cnu · Aug 20, 2011

Try this version - it actually works, which is a bonus

Code:

Option Explicit
Const msExistingSheetName As String = "Sheet1"
Const msExistingNameColumn As String = "A"

Const msDormantSheetName As String = "Sheet1"
Const msDormantNameColumn As String = "A"

Const msResultsSheetName As String = "Sheet3"

Const mlExistingStartDataRow As Long = 2
Const mlDormantStartDataRow As Long = 2

Sub GetDormantAssets()
Dim bError As Boolean
Dim lRow As Long
Dim lResultsRow As Long
Dim objNamesDictionary As Object
Dim rCur As Range
Dim sCurName As String
Dim vFile As Variant
Dim wbDormant As Workbook
Dim wsDormant As Worksheet
Dim wsExisting As Worksheet
Dim wsResults As Worksheet

bError = False
Set wsExisting = Nothing
On Error Resume Next
Set wsExisting = ThisWorkbook.Sheets(msExistingSheetName)
On Error GoTo 0
If wsExisting Is Nothing Then
    MsgBox prompt:="Error accessing sheet '" & msExistingSheetName & "'" & vbCrLf & Err.Description, _
            Buttons:=vbOKOnly + vbCritical
    bError = True
End If

If bError = False Then
    vFile = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*), *.xls*", _
                                      Title:="Please select Input Dormant File to be searched")
    If vFile = False Then
        MsgBox prompt:="Macro abandoned at user request", _
                Buttons:=vbOKOnly + vbInformation
        bError = True
    End If
End If

If bError = False Then
    Set wbDormant = Nothing
    On Error Resume Next
    Set wbDormant = Workbooks.Open(Filename:=vFile, ReadOnly:=True)
    On Error GoTo 0
    If wbDormant Is Nothing Then
        MsgBox prompt:="Unable to open file:" & vbCrLf & CStr(vFile) & vbCrLf & Err.Description, _
                Buttons:=vbCritical + vbOKOnly, _
                Title:="Error opening Dormant File"
        bError = True
    Else
        Set wsDormant = Nothing
        On Error Resume Next
        Set wsDormant = wbDormant.Sheets(msDormantSheetName)
        On Error GoTo 0
        If wsDormant Is Nothing Then
            MsgBox prompt:="Unable to open sheet '" & msDormantSheetName & "' from Dormant file" & vbCrLf & _
                            Err.Description, _
                    Buttons:=vbOKOnly + vbCritical, _
                    Title:="Error accessing Dormant file sheet"
            bError = True
        End If
    End If
End If

'-- Set up Names Dictionary  --
If bError = False Then
    
    Set objNamesDictionary = Nothing
    Set objNamesDictionary = CreateObject("Scripting.Dictionary")
    
    lRow = wsExisting.Cells(Rows.Count, msExistingNameColumn).End(xlUp).Row
    If lRow > 1 Then
        For Each rCur In wsExisting.Range(msExistingNameColumn & "2:" & msExistingNameColumn & lRow)
            sCurName = CStr(rCur.Value)
            On Error Resume Next
            objNamesDictionary.Add Key:=NormaliseName(sCurName), Item:=sCurName
            On Error GoTo 0
        Next rCur
    End If
    
End If

If bError = False Then
    Set wsResults = ThisWorkbook.Sheets(msResultsSheetName)
    wsResults.UsedRange.ClearContents
    wsResults.Range("A1").Value = "Name"
    lResultsRow = 1
    
    lRow = wsDormant.Cells(Rows.Count, msDormantNameColumn).End(xlUp).Row
    If lRow > 1 Then
        For Each rCur In wsDormant.Range(msDormantNameColumn & "2:" & msDormantNameColumn & lRow)
            sCurName = Trim$(CStr(rCur.Value))
            If sCurName <> "" Then
                If objNamesDictionary.exists(NormaliseName(sCurName)) Then
                    lResultsRow = lResultsRow + 1
                    wsResults.Cells(lResultsRow, 1).Value = sCurName
                End If
            End If
        Next rCur
    End If
End If

On Error Resume Next
objNamesDictionary.RemoveAll
Set objNamesDictionary = Nothing
wbDormant.Close

End Sub

Function NormaliseName(ByVal Stringx As String) As String
Dim lPtr As Long, lPtr1 As Long
Dim sCur As String, sResult As String
Dim saResult() As String

'-- replace anything other than A to Z, 0 to 9 or apostrophe with a space, and convert to uppercase
sResult = Stringx
For lPtr = 1 To Len(sResult)
    sCur = UCase$(Mid$(sResult, lPtr, 1))
    If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZ'0123456789", sCur) = 0 Then sCur = " "
    Mid$(sResult, lPtr, 1) = sCur
Next lPtr

sResult = WorksheetFunction.Trim(sResult)       ' remove leading, trailing & intermediate multiple spaces

'-- Now sort the result --
If sResult <> "" Then
    saResult = Split(sResult, " ")
    For lPtr = 0 To UBound(saResult) - 1
        sCur = saResult(lPtr)
        For lPtr1 = lPtr + 1 To UBound(saResult)
            
            If sCur > saResult(lPtr1) Then
                saResult(lPtr) = saResult(lPtr1)
                saResult(lPtr1) = sCur
                sCur = saResult(lPtr)
            End If
        Next lPtr1
    Next lPtr
    sResult = Join(saResult, " ")
End If

NormaliseName = sResult
End Function

How to compare data on differerent excel spreadsheets

hchristian

New Member

Excel Facts

al_b_cnu

Well-known Member

al_b_cnu

Well-known Member

al_b_cnu

Well-known Member

al_b_cnu

Well-known Member

Similar threads

Forum statistics

Share this page

How to compare data on differerent excel spreadsheets

hchristian

New Member

Excel Facts

al_b_cnu

Well-known Member

al_b_cnu

Well-known Member

al_b_cnu

Well-known Member

al_b_cnu

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock