Const msFromWorksheet As String = "Sheet1" 'From worksheet name
Const msToWorkSheet As String = "Sheet2" 'To Worksheet name
Const miSerial1Col As Integer = 1 'Serial1 column (A)
Const miSerial2Col As Integer = 8 'Serial2 column (J)
Const miDataColumns As Integer = 7 'No of data columns per entry
Const mbFirstMatchOnly As Boolean = False 'Set to True if code to stop after first match
Dim mwsFr As Worksheet, mwsTo As Worksheet
Sub MatchEntries()
Dim bFound As Boolean
Dim iMatchLength As Integer
Dim iPtr1 As Integer, iPtr2 As Integer
Dim iDataCols As Integer
Dim lRow1 As Long, lRow2 As Long, lRowResults As Long
Dim lRowEnd1 As Long, lRowEnd2 As Long
Dim lInterval As Long, lNextInterval As Long
Dim rCur1 As Range, rCur2 As Range, R1 As Range, R2 As Range
Dim sCur1 As String, sCur2 As String
Dim vReply As Variant
Do While iMatchLength = 0
vReply = Application.InputBox(prompt:="Enter no of characters to match", _
Title:="Partial Match length?")
If vReply = False Then
MsgBox "Macro abandoned"
Exit Sub
End If
iMatchLength = Int(Val(vReply))
Loop
Set mwsFr = Sheets(msFromWorksheet)
Set mwsTo = Sheets(msToWorkSheet)
'-- Get Serial1 range --
lRowEnd1 = mwsFr.Cells(Rows.Count, miSerial1Col).End(xlUp).Row
If lRowEnd1 < 3 Then
MsgBox "No Serial1 data present cor matching"
Exit Sub
End If
Set R1 = mwsFr.Range(Cells(2, miSerial1Col).Address, _
Cells(lRowEnd1, miSerial1Col).Address)
'-- Get Serial2 range --
lRowEnd2 = mwsFr.Cells(Rows.Count, miSerial2Col).End(xlUp).Row
If lRowEnd2 < 2 Then
MsgBox "No Serial2 data present"
Exit Sub
End If
Set R2 = mwsFr.Range(Cells(2, miSerial2Col).Address, _
Cells(lRowEnd2, miSerial2Col).Address)
mwsTo.UsedRange.ClearContents
lInterval = Int(lRowEnd2 / 100)
If lInterval < 1 Then lInterval = 1
lRowResults = 1
CopyDataLine FromRow1:=1, FromRow2:=1, ToRow:=1
For Each rCur1 In R1
lRow1 = rCur1.Row
'-- Report progress if required --
If lNextInterval < lRow1 Then
Application.StatusBar = "Processing row " & lRow1 & ": " & _
Format(lRow1 / lRowEnd1, "0.00%") & "complete"
lNextInterval = lRow1 + lInterval
End If
sCur1 = LCase$(CStr(rCur1.Value))
For Each rCur2 In R2
bFound = False
lRow2 = rCur2.Row
If lRow2 <> lRow1 Then
sCur2 = LCase$(CStr(rCur2.Value))
For iPtr1 = 1 To Len(sCur1) - iMatchLength + 1
If InStr(sCur2, Mid$(sCur1, iPtr1, iMatchLength)) <> 0 Then
'-- Here if partial match found --
lRowResults = lRowResults + 1
CopyDataLine FromRow1:=lRow1, FromRow2:=lRow2, ToRow:=lRowResults
bFound = True
Exit For
End If
Next iPtr1
If bFound And mbFirstMatchOnly Then Exit For
End If
Next rCur2
Next rCur1
Application.StatusBar = False
End Sub
Private Sub CopyDataLine(ByVal FromRow1 As Long, _
ByVal FromRow2 As Long, _
ByVal ToRow As Long)
Dim iPtr2 As Integer
Dim vaData1() As Variant, vaData2() As Variant, vaDataLine() As Variant
ReDim vaDataLine(1 To 1, 1 To (miDataColumns * 2))
vaData1 = mwsFr.Range(Cells(FromRow1, miSerial1Col).Address, _
Cells(FromRow1, miSerial1Col + miDataColumns - 1).Address).Value
vaData2 = mwsFr.Range(Cells(FromRow2, miSerial2Col).Address, _
Cells(FromRow2, miSerial2Col + miDataColumns - 1).Address).Value
For iPtr2 = 1 To miDataColumns
vaDataLine(1, iPtr2) = vaData1(1, iPtr2)
vaDataLine(1, iPtr2 + miDataColumns) = vaData2(1, iPtr2)
Next iPtr2
mwsTo.Range(Cells(ToRow, 1).Address, _
Cells(ToRow, (miDataColumns * 2)).Address).Value = vaDataLine
End Sub
