Did a bit of testing to see if it was worth it (speedwise) to check if the
new numbers couldn't make a match
anymore (3 matching numbers) and move to the next new numbers. The answer
seems to be no it isn't.
You could get the number of cycles down, but the checking for the condition
takes more time.
I did this because I am working on some 'real life' software where getting
fast through an array is important.
As I thought you might be interested in this I put all the relevant code in
here.
CompareNumbers2 is the one that will be most relevant for you.
Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private lStartTime As Long
Private lEndTime As Long
Sub CompareNumbers()
Dim arr1()
Dim arr2()
Dim LR As Long
Dim i As Long
Dim c1 As Byte
Dim c2 As Byte
Dim counter As Byte
Dim cyclecounter As Long
Dim bShortcut1 As Boolean
Dim bShortcut2 As Boolean
Dim lSleepTime As Long
Dim lWasteMax As Long
bShortcut1 = True
bShortcut2 = True
LR = 8
lSleepTime = 1000
lWasteMax = 80000000
arr1 = Range(Cells(5, 2), Cells(5, 8))
arr2 = Range(Cells(6, 2), Cells(LR, 8))
For i = 1 To LR - 5
counter = 0
'reset the format of the new numbers
'-----------------------------------
With Range(Cells(5, 2), Cells(5, 8)).Font
.Bold = False
.ColorIndex = 1
End With
For c1 = 1 To 7
For c2 = 1 To 7
'border around the new number being checked
'------------------------------------------
NoBorder Range(Cells(5, 2), Cells(5, 8))
MediumBorder Cells(5, c1 + 1)
Cells(i + 5, c2 + 1).Select
cyclecounter = cyclecounter + 1
'if match found format old and new number
'----------------------------------------
If arr1(1, c1) = arr2(i, c2) Then
With Cells(i + 5, c2 + 1).Font
.Bold = True
.ColorIndex = 3
End With
With Cells(5, c1 + 1).Font
.Bold = True
.ColorIndex = 3
End With
counter = counter + 1
'RunSleeper (lSleepTime)
RunTimeWaster (lWasteMax)
Exit For
End If
'get out if old numbers can't make it anymore
'--------------------------------------------
If bShortcut1 = True Then
If c1 - counter > 5 Then
'RunSleeper (lSleepTime)
RunTimeWaster (lWasteMax)
Exit For
End If
End If
'RunSleeper (lSleepTime)
RunTimeWaster (lWasteMax)
Next
'match found, move to next new numbers
'-------------------------------------
If counter > 2 Then
MsgBox "Bingo, we have a match in row " & i + 5
Exit For
End If
'get out if old numbers can't make it anymore
'--------------------------------------------
If bShortcut2 = True Then
If c1 - counter > 4 Then
counter = 0
Exit For
End If
End If
Next
Next
MsgBox "finished in " & cyclecounter & " cycles"
End Sub
Sub RunSleeper(lmilliSecs As Long)
Sleep (lmilliSecs)
'otherwise the display might freeze
'this doesn't work, still can freeze
'-----------------------------------
Application.ScreenUpdating = False
Application.ScreenUpdating = True
End Sub
Sub RunTimeWaster(lMax)
Dim i As Long
Dim x As Double
For i = 1 To lMax
'do nil
Next
'otherwise the display might freeze
'----------------------------------
Application.ScreenUpdating = False
Application.ScreenUpdating = True
End Sub
Sub CompareNumbers2()
Dim arr1()
Dim arr2()
Dim LR As Long
Dim i As Long
Dim c1 As Byte
Dim c2 As Byte
Dim counter As Byte
Dim lFoundCounter As Long
LR = Cells(65536, 2).End(xlUp).Row
LR = 14
arr1 = Range(Cells(5, 2), Cells(5, 8))
arr2 = Range(Cells(6, 2), Cells(LR, 8))
lStartTime = timeGetTime()
For i = 1 To LR - 5
counter = 0
For c1 = 1 To 7
For c2 = 1 To 7
'count and format matched number, move to next number in old
numbers
'-------------------------------------------------------------------
If arr1(1, c1) = arr2(i, c2) Then
Cells(i + 5, c2 + 1).Font.ColorIndex = 3
counter = counter + 1
Exit For
End If
Next
'found match, format new numbers, move to next new numbers
'---------------------------------------------------------
If counter > 2 Then
lFoundCounter = lFoundCounter + 1
Range(Cells(i + 5, 2), Cells(i + 5, 8)).Font.Bold = True
Exit For
End If
Next
'back to normal format if no match in new numbers
'------------------------------------------------
If counter < 3 Then
With Range(Cells(i + 5, 2), Cells(i + 5, 8)).Font
.Bold = False
.ColorIndex = 1
End With
End If
Next
lEndTime = timeGetTime()
MsgBox "Done in " & lEndTime - lStartTime & " msecs", , ""
MsgBox lFoundCounter & " matches found", , ""
End Sub
Sub NoBorder(rng As Range, Optional wSh As Worksheet)
'clears any border from the passed range
'---------------------------------------
Dim sh As Worksheet
If wSh Is Nothing Then
Set sh = ActiveWorkbook.ActiveSheet
Else
Set sh = wSh
End If
With sh.Range(rng.Address)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End Sub
Sub MediumBorder(rng As Range, Optional wSh As Worksheet)
'puts a medium border around the passed range
'--------------------------------------------
Dim sh As Worksheet
If wSh Is Nothing Then
Set sh = ActiveWorkbook.ActiveSheet
Else
Set sh = wSh
End If
With sh.Range(rng.Address)
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With
End Sub
Sub CopyBack()
'just for restoring the old range
'--------------------------------
Range(Cells(5, 17), Cells(35000, 23)).Copy Cells(5, 2)
End Sub
RBS
