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 it’s 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