Two of my worksheets (there are 10 total worksheets)in my workbook titled
"All Records" are titled "Confirm No Match" and the other titled "Payments No
Match". Each of these tables have columns titlted, "Name" and "Amount". I
would like to copy any duplicate records in the two worksheets with the same
"Amount" field and "Name" fields and copy them two a worksheet titled "Name
Wildcard". Because many of the names are misspelled, I was wondering how I
could use a single wildcard character. For example if the name was in the
Confirm No Match as "Ouimay" and in the Payment No Match as "Ouimey" and both
dollar amounts were $100.00, the row would be copied to the Name Wildcard
worksheet.

I looked at the other posts and in help and it seem that one has to specify
the location of the wildcard, I just want it to be any character or even
better if we could specify to match the name with 2 wildcards for more hits,
is that even possible.

Not sure if this will help you, but here is a function which compares the
contents of 2 cells and returns a percentage (a double) indicating how
similar they are.

Public Function Equivalence(rng1 As Range, rng2 As Range) As Double
Dim MtchTbl(100, 100)
Dim MyMax As Double, ThisMax As Double
Dim i As Integer, j As Integer, ii As Integer, jj As Integer
Dim st1 As String, st2 As String
If (rng1.Count 1) Or (rng2.Count 1) Then
MsgBox "Arguments for Equivalence function must be individual
cells", _
vbExclamation, "Equivalence error"
Equivalence = -1
End If
st1$ = Trim(LCase(rng1.Value))
st2$ = Trim(LCase(rng2.Value))
MyMax# = 0
For i% = Len(st1$) To 1 Step -1
For j% = Len(st2$) To 1 Step -1
If Mid(st1$, i%, 1) = Mid(st2$, j%, 1) Then
ThisMax# = 0
For ii% = (i% + 1) To Len(st1$)
For jj% = (j% + 1) To Len(st2$)
If MtchTbl(ii%, jj%) ThisMax# Then
ThisMax# = MtchTbl(ii%, jj%)
End If
Next jj%
Next ii%
MtchTbl(i%, j%) = ThisMax# + 1
If (ThisMax# + 1) ThisMax# Then
MyMax# = ThisMax# + 1
End If
End If
Next j%
Next i%
Equivalence# = MyMax# / ((Len(st1$) + Len(st2$)) / 2)
End Function

Try it and see it if can help you match names which are close, but not
exactly the same.

Hope this helps,

Hutch

"JOUIOUI" wrote:

Two of my worksheets (there are 10 total worksheets)in my workbook titled
"All Records" are titled "Confirm No Match" and the other titled "Payments No
Match". Each of these tables have columns titlted, "Name" and "Amount". I
would like to copy any duplicate records in the two worksheets with the same
"Amount" field and "Name" fields and copy them two a worksheet titled "Name
Wildcard". Because many of the names are misspelled, I was wondering how I
could use a single wildcard character. For example if the name was in the
Confirm No Match as "Ouimay" and in the Payment No Match as "Ouimey" and both
dollar amounts were $100.00, the row would be copied to the Name Wildcard
worksheet.

I looked at the other posts and in help and it seem that one has to specify
the location of the wildcard, I just want it to be any character or even
better if we could specify to match the name with 2 wildcards for more hits,
is that even possible.

Hi Joyce,

Finding matches is difficult where one or more characters, in any position,
may be different. The function I sent you can help finding inexact matches.
It needs to be called repeatedly from a subroutine, to compare two cells at a
time. If you give me a little more information, I will write you the macro to
do this, with instructions on how to run it.

Can you tell me:
1. On the "Confirm No Match" sheet, which is the Name column? Which is the
Amount column? What row has the first Name data? Are those the only columns
on the sheet?
2. Same info for the "Payments No Match" sheet

I thought on the "Name Wildcard" sheet I would list the source sheet name &
row number, plus the Name & Amount data values. Is that what you had in mind?

Once I have this information, the macro should not take long to write.
Regards,

Hutch

"JOUIOUI" wrote:

Hi Tom,

Wow this is very complex for me, I'm thinking I need to take the two tables
I am comparing and combine them together and then run the code, is that
correct?

thanks
Joyce

"Tom Hutchins" wrote:

Not sure if this will help you, but here is a function which compares the
contents of 2 cells and returns a percentage (a double) indicating how
similar they are.

Public Function Equivalence(rng1 As Range, rng2 As Range) As Double
Dim MtchTbl(100, 100)
Dim MyMax As Double, ThisMax As Double
Dim i As Integer, j As Integer, ii As Integer, jj As Integer
Dim st1 As String, st2 As String
If (rng1.Count 1) Or (rng2.Count 1) Then
MsgBox "Arguments for Equivalence function must be individual
cells", _
vbExclamation, "Equivalence error"
Equivalence = -1
End If
st1$ = Trim(LCase(rng1.Value))
st2$ = Trim(LCase(rng2.Value))
MyMax# = 0
For i% = Len(st1$) To 1 Step -1
For j% = Len(st2$) To 1 Step -1
If Mid(st1$, i%, 1) = Mid(st2$, j%, 1) Then
ThisMax# = 0
For ii% = (i% + 1) To Len(st1$)
For jj% = (j% + 1) To Len(st2$)
If MtchTbl(ii%, jj%) ThisMax# Then
ThisMax# = MtchTbl(ii%, jj%)
End If
Next jj%
Next ii%
MtchTbl(i%, j%) = ThisMax# + 1
If (ThisMax# + 1) ThisMax# Then
MyMax# = ThisMax# + 1
End If
End If
Next j%
Next i%
Equivalence# = MyMax# / ((Len(st1$) + Len(st2$)) / 2)
End Function

Try it and see it if can help you match names which are close, but not
exactly the same.

Hope this helps,

Hutch

"JOUIOUI" wrote:

Two of my worksheets (there are 10 total worksheets)in my workbook titled
"All Records" are titled "Confirm No Match" and the other titled "Payments No
Match". Each of these tables have columns titlted, "Name" and "Amount". I
would like to copy any duplicate records in the two worksheets with the same
"Amount" field and "Name" fields and copy them two a worksheet titled "Name
Wildcard". Because many of the names are misspelled, I was wondering how I
could use a single wildcard character. For example if the name was in the
Confirm No Match as "Ouimay" and in the Payment No Match as "Ouimey" and both
dollar amounts were $100.00, the row would be copied to the Name Wildcard
worksheet.

I looked at the other posts and in help and it seem that one has to specify
the location of the wildcard, I just want it to be any character or even
better if we could specify to match the name with 2 wildcards for more hits,
is that even possible.

HI Again Tom,

I so much appreciate your help and would like to ask you one other favor...I
really want to try to understand the code so I'd appreciate any explanations
you can put in the macro so I can follow the logic and learn from it. I've
put the answers to your questions in your text below in ()

Again, thanks I have to think this is very difficult code and quite a task
to accomplish so I do indeed appreciate your time, efforts and sharing your
knowledge.

Joyce

Joyce
"Tom Hutchins" wrote:

Hi Joyce,

Finding matches is difficult where one or more characters, in any position,
may be different. The function I sent you can help finding inexact matches.
It needs to be called repeatedly from a subroutine, to compare two cells at a
time. If you give me a little more information, I will write you the macro to
do this, with instructions on how to run it.

Can you tell me:
1. On the "Confirm No Match" sheet, which is the Name column? (Col E and the format is Last Name, First Name however sometimes there is a space after the comma and sometimes not and starts on row 2) Which is the Amount column? (The amount column is col C starting on row 2) What row has the first Name data? Are those the only columns
on the sheet? (no, there are two empty columns - Col A has a column heading of TRANS# and Col B column heading is NOTES, Column C is AMOUNT, D is ACCTNB and E is NAME)
2. Same info for the "Payments No Match" sheet. (this sheet is set up with the same column headings as the Confirm No Match sheet)

I thought on the "Name Wildcard" sheet I would list the source sheet name &
row number, plus the Name & Amount data values. Is that what you had in mind?

Once I have this information, the macro should not take long to write.
Regards,

Hutch

"JOUIOUI" wrote:

Hi Tom,

Wow this is very complex for me, I'm thinking I need to take the two tables
I am comparing and combine them together and then run the code, is that
correct?

thanks
Joyce

"Tom Hutchins" wrote:

Not sure if this will help you, but here is a function which compares the
contents of 2 cells and returns a percentage (a double) indicating how
similar they are.

Public Function Equivalence(rng1 As Range, rng2 As Range) As Double
Dim MtchTbl(100, 100)
Dim MyMax As Double, ThisMax As Double
Dim i As Integer, j As Integer, ii As Integer, jj As Integer
Dim st1 As String, st2 As String
If (rng1.Count 1) Or (rng2.Count 1) Then
MsgBox "Arguments for Equivalence function must be individual
cells", _
vbExclamation, "Equivalence error"
Equivalence = -1
End If
st1$ = Trim(LCase(rng1.Value))
st2$ = Trim(LCase(rng2.Value))
MyMax# = 0
For i% = Len(st1$) To 1 Step -1
For j% = Len(st2$) To 1 Step -1
If Mid(st1$, i%, 1) = Mid(st2$, j%, 1) Then
ThisMax# = 0
For ii% = (i% + 1) To Len(st1$)
For jj% = (j% + 1) To Len(st2$)
If MtchTbl(ii%, jj%) ThisMax# Then
ThisMax# = MtchTbl(ii%, jj%)
End If
Next jj%
Next ii%
MtchTbl(i%, j%) = ThisMax# + 1
If (ThisMax# + 1) ThisMax# Then
MyMax# = ThisMax# + 1
End If
End If
Next j%
Next i%
Equivalence# = MyMax# / ((Len(st1$) + Len(st2$)) / 2)
End Function

Try it and see it if can help you match names which are close, but not
exactly the same.

Hope this helps,

Hutch

"JOUIOUI" wrote:

Two of my worksheets (there are 10 total worksheets)in my workbook titled
"All Records" are titled "Confirm No Match" and the other titled "Payments No
Match". Each of these tables have columns titlted, "Name" and "Amount". I
would like to copy any duplicate records in the two worksheets with the same
"Amount" field and "Name" fields and copy them two a worksheet titled "Name
Wildcard". Because many of the names are misspelled, I was wondering how I
could use a single wildcard character. For example if the name was in the
Confirm No Match as "Ouimay" and in the Payment No Match as "Ouimey" and both
dollar amounts were $100.00, the row would be copied to the Name Wildcard
worksheet.

I looked at the other posts and in help and it seem that one has to specify
the location of the wildcard, I just want it to be any character or even
better if we could specify to match the name with 2 wildcards for more hits,
is that even possible.

Hi Joyce,

Okay, I created a test workbook and wrote the macro. Seems to be working
fine. I added lots of comments to the code. It's a bit lengthy, but Excel
doesn't care. Here it is:

Option Explicit

'Constants are defined here for easy maintenance.
'CNM_NameCol is the Name column on the Confirm sheet
Const CNM_NameCol = 5
'CNM_AmtColOffset gets you to the Amount column from the Name column
Const CNM_AmtColOffset = -2
'CNM_FstColOffset gets you to column A
Const CNM_FstColOffset = -4
'CNM_FstRow is the number of the first row of data on the Confirm sheet
Const CNM_FstRow = 2
'PNM_NameCol is the Name column on the Payment sheet
Const PNM_NameCol = 5
'PNM_AmtColOffset gets you to the Amount column from the Name column
Const PNM_AmtColOffset = -2
'PNM_FstColOffset gets you to column A
Const PNM_FstColOffset = -4
'PNM_FstRow is the number of the first row of data on the Payment sheet
Const PNM_FstRow = 2
'Sheet names
Const CNM_ShtName = "Confirm No Match"
Const PNM_ShtName = "Payments No Match"
Const NewShtName = "Name Wildcard"

Sub Copy_Dupl_Recs()
'Declare local variables.
Dim c As Range, d As Range, e As Range
Dim BestCell As String, BestPct As Double
Dim Rng1 As Range, Rng2 As Range
Dim x As Long, y As Double
Dim msg1 As String, NewWS As Worksheet
'Begin error handling.
On Error GoTo CDRerr1
'Delete the sheet Name Wildcard if it already exists.
On Error Resume Next
Application.DisplayAlerts = False
Sheets(NewShtName).Delete
Application.DisplayAlerts = True
On Error GoTo CDRerr1
'Add a new sheet after all other sheets.
Sheets.Add After:=Sheets(Sheets.Count)
'Rename the new sheet.
ActiveSheet.Name = NewShtName
'Create a heading for the Confirm sheet columns
Range("A1").Value = CNM_ShtName
'Select & merge 6 cells for the heading.
Range("A1:F1").Select
Selection.Merge
Selection.HorizontalAlignment = xlCenter
'Apply some border formatting (recorded code).
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
'Create a heading for the Confirm sheet columns
Range("G1").Value = PNM_ShtName
'Select & merge 6 cells for the heading.
Range("G1:L1").Select
Selection.Merge
Selection.HorizontalAlignment = xlCenter
'Apply some border formatting (recorded code).
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
'Copy headings from the Confirm sheet.
ActiveSheet.Range("A2").Value = Sheets(CNM_ShtName).Range("A1").Value
ActiveSheet.Range("B2").Value = Sheets(CNM_ShtName).Range("B1").Value
ActiveSheet.Range("C2").Value = Sheets(CNM_ShtName).Range("C1").Value
ActiveSheet.Range("D2").Value = Sheets(CNM_ShtName).Range("D1").Value
ActiveSheet.Range("E2").Value = Sheets(CNM_ShtName).Range("E1").Value
ActiveSheet.Range("F2").Value = "Row"
'Copy headings from the Payment sheet.
ActiveSheet.Range("G2").Value = Sheets(PNM_ShtName).Range("A1").Value
ActiveSheet.Range("H2").Value = Sheets(PNM_ShtName).Range("B1").Value
ActiveSheet.Range("I2").Value = Sheets(PNM_ShtName).Range("C1").Value
ActiveSheet.Range("J2").Value = Sheets(PNM_ShtName).Range("D1").Value
ActiveSheet.Range("K2").Value = Sheets(PNM_ShtName).Range("E1").Value
ActiveSheet.Range("L2").Value = "Row"
ActiveSheet.Range("M2").Value = "Equiv %"
'Find the range of cells comprising the Name data on the Confirm sheet.
Sheets(CNM_ShtName).Activate
x& = Cells(Rows.Count, CNM_NameCol).End(xlUp).Row
'Define a range Rng1 which includes all the Name data on the Confirm sheet.
Set Rng1 = Range(Cells(CNM_FstRow, CNM_NameCol), Cells(x&, CNM_NameCol))
'Find the range of cells comprising the Name data on the Payment sheet.
Sheets(PNM_ShtName).Activate
x& = Cells(Rows.Count, PNM_NameCol).End(xlUp).Row
'Define a range Rng2 which includes all the Name data on the Payment sheet.
Set Rng2 = Range(Cells(PNM_FstRow, PNM_NameCol), Cells(x&, PNM_NameCol))
'Check each Name in Rng1 against all the Names in Rng2 if
'they have the same Amount.
Sheets(CNM_ShtName).Activate
For Each c In Rng1
'Each time we start testing a new Name from Rng1, reset BestCell and BestPct.
'BestCell is the address of the closest-matching Name so far on the Payment
sheet.
BestCell$ = vbNullString
'BestPct is the highest correlation of the Rng2 Names we have tested for the
'current Rng1 Name.
BestPct# = 0
'Check the current Confirm sheet Name against each payment sheet Name.
For Each d In Rng2
'If the Amount doesn't match, we don't need to do anything with the names.
If c.Offset(0, CNM_AmtColOffset).Value = _
d.Offset(0, PNM_AmtColOffset).Value Then
'The Amount matches, so call the Equivalence function. Returns a percentage
(as a
'double) indicating the percentage of similarity.
y# = Equivalence(c, d)
'If 1 was returned, we found an exact match. Store BestPct and BestCell, then
'break out of the inner For..Next loop. Don't need to check any more Payment
'Names.
If y# = 1 Then
BestPct# = y#
BestCell$ = d.Address
Exit For
End If
'If the percentage returned is higher than BestPct, the Payment Name we are
testing
'is the best match we have found so far for the current Rng1 Name. Store
BestPct
'and BestCell, and continue checking Payment Names (Rng2).
If y# BestPct# Then
BestPct# = y#
BestCell$ = d.Address
End If
End If
Next d
'We have checked all the Payment Names (Rng2 cells) for the current Confirm
'Name (Rng1 cell), or we found an exact match. If BestPct is still zero, no
Payment
'Names matched at all - do nothing. If some kind of match was found, copy
those
'records to the new sheet.
If BestPct# 0 Then
'Define a range (e) which includes all the cells in BestCell record.
Set e = Sheets(PNM_ShtName).Range(BestCell$)
'Call CopyRecs to copy the Confirm & Payment records to the first empty row
on the
'new sheet.
Call CopyRecs(Range(c.Offset(0, CNM_FstColOffset), c), _
Range(e.Offset(0, PNM_FstColOffset), e), BestPct#)
Set e = Nothing
End If
Next c
'Autosize all the cells.
Sheets(NewShtName).Activate
Cells.Select
Cells.EntireColumn.AutoFit
Range("A3").Select
Cleanup1:
'Free memory used by object variables.
Set Rng1 = Nothing
Set Rng2 = Nothing
Set e = Nothing
'Tell user we are done.
MsgBox "Done!", , "Copy_Dupl_Recs"
Exit Sub
CDRerr1:
'The program jumps here if an error is encountered. Display the error
'text from Excel, then go to Cleanup1.
If Err.Number < 0 Then
msg1$ = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg1$, , "Copy_Dupl_Recs", Err.HelpFile, Err.HelpContext
End If
GoTo Cleanup1
End Sub

Sub CopyRecs(Rng1 As Range, Rng2 As Range, Pct As Double)
'Declare local variables.
Dim NewRow As Long
'Go to the new sheet.
Sheets(NewShtName).Activate
'Find the first empty row in the Name column.
NewRow& = Cells(Rows.Count, CNM_NameCol).End(xlUp).Row + 1
'Fill in the data from the Confirm & Payment records, plus the
'row number where each was found.
Range("A" & NewRow&).Value = Rng1.Range("A1").Value
Range("B" & NewRow&).Value = Rng1.Range("B1").Value
Range("C" & NewRow&).Value = Rng1.Range("C1").Value
Range("D" & NewRow&).Value = Rng1.Range("D1").Value
Range("E" & NewRow&).Value = Rng1.Range("E1").Value
Range("F" & NewRow&).Value = Rng1.Range("A1").Row
Range("G" & NewRow&).Value = Rng2.Range("A1").Value
Range("H" & NewRow&).Value = Rng2.Range("B1").Value
Range("I" & NewRow&).Value = Rng2.Range("C1").Value
Range("J" & NewRow&).Value = Rng2.Range("D1").Value
Range("K" & NewRow&).Value = Rng2.Range("E1").Value
Range("L" & NewRow&).Value = Rng2.Range("A1").Row
'Also include the final Equivalence percentage for these records.
Range("M" & NewRow&).Value = Pct#
Range("M" & NewRow&).NumberFormat = "0%"
End Sub

Public Function Equivalence(Rng1 As Range, _
Rng2 As Range) As Double
Dim MtchTbl(100, 100)
Dim MyMax As Double, ThisMax As Double
Dim i As Integer, j As Integer, ii As Integer, jj As Integer
Dim st1 As String, st2 As String
If (Rng1.Count 1) Or (Rng2.Count 1) Then
MsgBox "Arguments for Equivalence function must be " & _
"individual cells", vbExclamation, "Equivalence error"
Equivalence = -1
End If
st1$ = Trim(LCase(Rng1.Value))
st2$ = Trim(LCase(Rng2.Value))
MyMax# = 0
For i% = Len(st1$) To 1 Step -1
For j% = Len(st2$) To 1 Step -1
If Mid(st1$, i%, 1) = Mid(st2$, j%, 1) Then
ThisMax# = 0
For ii% = (i% + 1) To Len(st1$)
For jj% = (j% + 1) To Len(st2$)
If MtchTbl(ii%, jj%) ThisMax# Then
ThisMax# = MtchTbl(ii%, jj%)
End If
Next jj%
Next ii%
MtchTbl(i%, j%) = ThisMax# + 1
If (ThisMax# + 1) ThisMax# Then
MyMax# = ThisMax# + 1
End If
End If
Next j%
Next i%
Equivalence# = MyMax# / ((Len(st1$) + Len(st2$)) / 2)
End Function

Right-click on any sheet tab in the workbook. From the menu that pops up,
select View Code. You will be taken to the Visual Basic Editor (VBE). Press
Ctrl-R (Ctrl button plus R). There should be a window, probably along the
left side of the screen, that is titled Project. In that window, click on the
line that says VBAProject (Joyce.xls), where Joyce.xls is the name of the
workbook. Select Module from the Insert menu to add a VBA module to the
workbook. Now copy all the VBA code from this email and paste it into the
module.

If some lines are red, that is an error caused by the line wrapping in the
newsgroup. I have tried to prevent this, but... You will have to fix each one
of these before you can run the macro. When you can run Debug Compile
VBAPRoject with no errors, you should be ready.

To run the macro, click any cell on the Confirm No Match sheet (just to make
sure its the active workbook). Select Tools Macro Macros. On the list
of available macros that pops up, select Copy_Dupl_Recs and click OK.

If you prefer, I can just email you the test workbook I used to develop the
code. You can try it there. If it is what you want, open your workbook also.
In the VBA Project Explorer window, just drag Module1 from the test workbook
to your workbook. Easy, huh?

Let me know how it works out (or not),

Hutch

"JOUIOUI" wrote:

HI Again Tom,

I so much appreciate your help and would like to ask you one other favor...I
really want to try to understand the code so I'd appreciate any explanations
you can put in the macro so I can follow the logic and learn from it. I've
put the answers to your questions in your text below in ()

Again, thanks I have to think this is very difficult code and quite a task
to accomplish so I do indeed appreciate your time, efforts and sharing your
knowledge.

Joyce

Hi Hutch,

Thanks so much for taking the time to explain your code. I am having
trouble getting it to work in my workbook so I thought if I looked at yours,
it may help me out. My e-mail is .

I truly appreciate your time and effort to help me. Thank you.

Joyce

"Tom Hutchins" wrote:

Hi Joyce,

Okay, I created a test workbook and wrote the macro. Seems to be working
fine. I added lots of comments to the code. It's a bit lengthy, but Excel
doesn't care. Here it is:

Option Explicit

'Constants are defined here for easy maintenance.
'CNM_NameCol is the Name column on the Confirm sheet
Const CNM_NameCol = 5
'CNM_AmtColOffset gets you to the Amount column from the Name column
Const CNM_AmtColOffset = -2
'CNM_FstColOffset gets you to column A
Const CNM_FstColOffset = -4
'CNM_FstRow is the number of the first row of data on the Confirm sheet
Const CNM_FstRow = 2
'PNM_NameCol is the Name column on the Payment sheet
Const PNM_NameCol = 5
'PNM_AmtColOffset gets you to the Amount column from the Name column
Const PNM_AmtColOffset = -2
'PNM_FstColOffset gets you to column A
Const PNM_FstColOffset = -4
'PNM_FstRow is the number of the first row of data on the Payment sheet
Const PNM_FstRow = 2
'Sheet names
Const CNM_ShtName = "Confirm No Match"
Const PNM_ShtName = "Payments No Match"
Const NewShtName = "Name Wildcard"

Sub Copy_Dupl_Recs()
'Declare local variables.
Dim c As Range, d As Range, e As Range
Dim BestCell As String, BestPct As Double
Dim Rng1 As Range, Rng2 As Range
Dim x As Long, y As Double
Dim msg1 As String, NewWS As Worksheet
'Begin error handling.
On Error GoTo CDRerr1
'Delete the sheet Name Wildcard if it already exists.
On Error Resume Next
Application.DisplayAlerts = False
Sheets(NewShtName).Delete
Application.DisplayAlerts = True
On Error GoTo CDRerr1
'Add a new sheet after all other sheets.
Sheets.Add After:=Sheets(Sheets.Count)
'Rename the new sheet.
ActiveSheet.Name = NewShtName
'Create a heading for the Confirm sheet columns
Range("A1").Value = CNM_ShtName
'Select & merge 6 cells for the heading.
Range("A1:F1").Select
Selection.Merge
Selection.HorizontalAlignment = xlCenter
'Apply some border formatting (recorded code).
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
'Create a heading for the Confirm sheet columns
Range("G1").Value = PNM_ShtName
'Select & merge 6 cells for the heading.
Range("G1:L1").Select
Selection.Merge
Selection.HorizontalAlignment = xlCenter
'Apply some border formatting (recorded code).
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
'Copy headings from the Confirm sheet.
ActiveSheet.Range("A2").Value = Sheets(CNM_ShtName).Range("A1").Value
ActiveSheet.Range("B2").Value = Sheets(CNM_ShtName).Range("B1").Value
ActiveSheet.Range("C2").Value = Sheets(CNM_ShtName).Range("C1").Value
ActiveSheet.Range("D2").Value = Sheets(CNM_ShtName).Range("D1").Value
ActiveSheet.Range("E2").Value = Sheets(CNM_ShtName).Range("E1").Value
ActiveSheet.Range("F2").Value = "Row"
'Copy headings from the Payment sheet.
ActiveSheet.Range("G2").Value = Sheets(PNM_ShtName).Range("A1").Value
ActiveSheet.Range("H2").Value = Sheets(PNM_ShtName).Range("B1").Value
ActiveSheet.Range("I2").Value = Sheets(PNM_ShtName).Range("C1").Value
ActiveSheet.Range("J2").Value = Sheets(PNM_ShtName).Range("D1").Value
ActiveSheet.Range("K2").Value = Sheets(PNM_ShtName).Range("E1").Value
ActiveSheet.Range("L2").Value = "Row"
ActiveSheet.Range("M2").Value = "Equiv %"
'Find the range of cells comprising the Name data on the Confirm sheet.
Sheets(CNM_ShtName).Activate
x& = Cells(Rows.Count, CNM_NameCol).End(xlUp).Row
'Define a range Rng1 which includes all the Name data on the Confirm sheet.
Set Rng1 = Range(Cells(CNM_FstRow, CNM_NameCol), Cells(x&, CNM_NameCol))
'Find the range of cells comprising the Name data on the Payment sheet.
Sheets(PNM_ShtName).Activate
x& = Cells(Rows.Count, PNM_NameCol).End(xlUp).Row
'Define a range Rng2 which includes all the Name data on the Payment sheet.
Set Rng2 = Range(Cells(PNM_FstRow, PNM_NameCol), Cells(x&, PNM_NameCol))
'Check each Name in Rng1 against all the Names in Rng2 if
'they have the same Amount.
Sheets(CNM_ShtName).Activate
For Each c In Rng1
'Each time we start testing a new Name from Rng1, reset BestCell and BestPct.
'BestCell is the address of the closest-matching Name so far on the Payment
sheet.
BestCell$ = vbNullString
'BestPct is the highest correlation of the Rng2 Names we have tested for the
'current Rng1 Name.
BestPct# = 0
'Check the current Confirm sheet Name against each payment sheet Name.
For Each d In Rng2
'If the Amount doesn't match, we don't need to do anything with the names.
If c.Offset(0, CNM_AmtColOffset).Value = _
d.Offset(0, PNM_AmtColOffset).Value Then
'The Amount matches, so call the Equivalence function. Returns a percentage
(as a
'double) indicating the percentage of similarity.
y# = Equivalence(c, d)
'If 1 was returned, we found an exact match. Store BestPct and BestCell, then
'break out of the inner For..Next loop. Don't need to check any more Payment
'Names.
If y# = 1 Then
BestPct# = y#
BestCell$ = d.Address
Exit For
End If
'If the percentage returned is higher than BestPct, the Payment Name we are
testing
'is the best match we have found so far for the current Rng1 Name. Store
BestPct
'and BestCell, and continue checking Payment Names (Rng2).
If y# BestPct# Then
BestPct# = y#
BestCell$ = d.Address
End If
End If
Next d
'We have checked all the Payment Names (Rng2 cells) for the current Confirm
'Name (Rng1 cell), or we found an exact match. If BestPct is still zero, no
Payment
'Names matched at all - do nothing. If some kind of match was found, copy
those
'records to the new sheet.
If BestPct# 0 Then
'Define a range (e) which includes all the cells in BestCell record.
Set e = Sheets(PNM_ShtName).Range(BestCell$)
'Call CopyRecs to copy the Confirm & Payment records to the first empty row
on the
'new sheet.
Call CopyRecs(Range(c.Offset(0, CNM_FstColOffset), c), _
Range(e.Offset(0, PNM_FstColOffset), e), BestPct#)
Set e = Nothing
End If
Next c
'Autosize all the cells.
Sheets(NewShtName).Activate
Cells.Select
Cells.EntireColumn.AutoFit
Range("A3").Select
Cleanup1:
'Free memory used by object variables.
Set Rng1 = Nothing
Set Rng2 = Nothing
Set e = Nothing
'Tell user we are done.
MsgBox "Done!", , "Copy_Dupl_Recs"
Exit Sub
CDRerr1:
'The program jumps here if an error is encountered. Display the error
'text from Excel, then go to Cleanup1.
If Err.Number < 0 Then
msg1$ = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg1$, , "Copy_Dupl_Recs", Err.HelpFile, Err.HelpContext
End If
GoTo Cleanup1
End Sub

Sub CopyRecs(Rng1 As Range, Rng2 As Range, Pct As Double)
'Declare local variables.
Dim NewRow As Long
'Go to the new sheet.
Sheets(NewShtName).Activate
'Find the first empty row in the Name column.
NewRow& = Cells(Rows.Count, CNM_NameCol).End(xlUp).Row + 1
'Fill in the data from the Confirm & Payment records, plus the
'row number where each was found.
Range("A" & NewRow&).Value = Rng1.Range("A1").Value
Range("B" & NewRow&).Value = Rng1.Range("B1").Value
Range("C" & NewRow&).Value = Rng1.Range("C1").Value
Range("D" & NewRow&).Value = Rng1.Range("D1").Value
Range("E" & NewRow&).Value = Rng1.Range("E1").Value
Range("F" & NewRow&).Value = Rng1.Range("A1").Row
Range("G" & NewRow&).Value = Rng2.Range("A1").Value
Range("H" & NewRow&).Value = Rng2.Range("B1").Value
Range("I" & NewRow&).Value = Rng2.Range("C1").Value
Range("J" & NewRow&).Value = Rng2.Range("D1").Value
Range("K" & NewRow&).Value = Rng2.Range("E1").Value
Range("L" & NewRow&).Value = Rng2.Range("A1").Row
'Also include the final Equivalence percentage for these records.
Range("M" & NewRow&).Value = Pct#
Range("M" & NewRow&).NumberFormat = "0%"
End Sub

Public Function Equivalence(Rng1 As Range, _
Rng2 As Range) As Double
Dim MtchTbl(100, 100)
Dim MyMax As Double, ThisMax As Double
Dim i As Integer, j As Integer, ii As Integer, jj As Integer
Dim st1 As String, st2 As String
If (Rng1.Count 1) Or (Rng2.Count 1) Then
MsgBox "Arguments for Equivalence function must be " & _
"individual cells", vbExclamation, "Equivalence error"
Equivalence = -1
End If
st1$ = Trim(LCase(Rng1.Value))
st2$ = Trim(LCase(Rng2.Value))
MyMax# = 0
For i% = Len(st1$) To 1 Step -1
For j% = Len(st2$) To 1 Step -1
If Mid(st1$, i%, 1) = Mid(st2$, j%, 1) Then
ThisMax# = 0
For ii% = (i% + 1) To Len(st1$)
For jj% = (j% + 1) To Len(st2$)
If MtchTbl(ii%, jj%) ThisMax# Then
ThisMax# = MtchTbl(ii%, jj%)
End If
Next jj%
Next ii%
MtchTbl(i%, j%) = ThisMax# + 1
If (ThisMax# + 1) ThisMax# Then
MyMax# = ThisMax# + 1
End If
End If
Next j%
Next i%
Equivalence# = MyMax# / ((Len(st1$) + Len(st2$)) / 2)
End Function

Right-click on any sheet tab in the workbook. From the menu that pops up,
select View Code. You will be taken to the Visual Basic Editor (VBE). Press
Ctrl-R (Ctrl button plus R). There should be a window, probably along the
left side of the screen, that is titled Project. In that window, click on the
line that says VBAProject (Joyce.xls), where Joyce.xls is the name of the
workbook. Select Module from the Insert menu to add a VBA module to the
workbook. Now copy all the VBA code from this email and paste it into the
module.

If some lines are red, that is an error caused by the line wrapping in the
newsgroup. I have tried to prevent this, but... You will have to fix each one
of these before you can run the macro. When you can run Debug Compile
VBAPRoject with no errors, you should be ready.

To run the macro, click any cell on the Confirm No Match sheet (just to make
sure its the active workbook). Select Tools Macro Macros. On the list
of available macros that pops up, select Copy_Dupl_Recs and click OK.

If you prefer, I can just email you the test workbook I used to develop the
code. You can try it there. If it is what you want, open your workbook also.
In the VBA Project Explorer window, just drag Module1 from the test workbook
to your workbook. Easy, huh?

Let me know how it works out (or not),

Hutch

"JOUIOUI" wrote:

HI Again Tom,

I so much appreciate your help and would like to ask you one other favor...I
really want to try to understand the code so I'd appreciate any explanations
you can put in the macro so I can follow the logic and learn from it. I've
put the answers to your questions in your text below in ()

Again, thanks I have to think this is very difficult code and quite a task
to accomplish so I do indeed appreciate your time, efforts and sharing your
knowledge.

Joyce