I think I've found a couple of problems.
#1 may be a "case" issue.
I've found a couple of cases where lowercase is used in one list, but uppercase
is used in another:
(p01-070161-01411-A100)
#2.. You're using an Interval Halving technique for searching the list.
However, for it to work properly, the data has to be sorted correctly.
Unfortunately, it doesn't look like it's sorting properly.
Specifically,
the ASCII code for "-" is 45
the ASCII code for "0" is 48
(1-9 are codes 49-57)
But in the sort, "-" is sorted AFTER numbers.
(see rows:
6115: 020-SUB-0011
6116: 02-16917-3600
12513: 400-TUNECVR-0003
12514: 40-26314
)
for that reason, when the interval happens to test lines comparing 020 to 02-,
it assumes that the 020 should be AFTER 02-, but the next iteration finds that
it is outside the range,
and therefore assumes it cannot find it.
I'm not sure what can be done about this sorting problem, however, I have an
alternate solution.
I prefer to use a Dictionary object instead of arrays.
try this macro:
Sub CompareUsingDict()
Dim x As Long
Dim sdlast As Long
Dim pilast As Long
Dim y As Object
Dim Dict_SD, Dict_PH
Dim tstart, tstop, TElapsed, TMin, TSec, msg
tstart = Timer
'-----------------------------------------------------
Set Dict_SD = CreateObject("Scripting.Dictionary")
Dict_SD.RemoveAll
Set Dict_PH = CreateObject("Scripting.Dictionary")
Dict_PH.RemoveAll
'-----------------------------------------------------
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheet1.Activate
'Get the size of the other two databases
sdlast = Sheet2.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
pilast = Sheet3.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
For x = 3 To sdlast
If (Not Dict_SD.exists(UCase(Sheet2.Cells(x, 1).Value))) Then
Dict_SD.Add UCase(Sheet2.Cells(x, 1).Value), x
End If
Next x
For x = 3 To pilast
If (Not Dict_PH.exists(UCase(Sheet3.Cells(x, 1).Value))) Then
Dict_PH.Add UCase(Sheet3.Cells(x, 1).Value), x
End If
Next x
x = 3
Do While Not Cells(x, 1) = ""
If (Dict_SD.exists(UCase(Sheet1.Cells(x, 1).Value))) Then
Sheet1.Cells(x, 4).Value = Dict_SD.Item(UCase(Sheet1.Cells(x, 1).Value)) '"Y"
If (Dict_PH.exists(ucase(Sheet1.Cells(x, 1).Value))) Then
Sheet1.Cells(x, 5).Value = Dict_PH.Item(ucase(Sheet1.Cells(x, 1).Value)) '"Y"
x = x + 1
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
msg = "Using Dictionary"
tstop = Timer
TMin = 0
TElapsed = tstop - tstart
TMin = TElapsed \ 60
TSec = TElapsed Mod 60
msg = msg & Chr(13) & Chr(13)
If (TMin > 0) Then msg = msg & TMin & " mins "
msg = msg & TSec & " sec"
MsgBox msg
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
End Sub
hope this helps.
Paul
-----------------------------------------
"Do all the good you can,
By all the means you can,
In all the ways you can,
In all the places you can,
At all the times you can,
To all the people you can,
As long as ever you can." - John Wesley
-----------------------------------------
________________________________
From: Scott <scott@mountainhighbnb.com>
To: ExcelVBA@yahoogroups.com
Sent: Thu, October 6, 2011 4:08:52 PM
Subject: [ExcelVBA] Binary Search Problem
I'm having a problem with a binary search of three databases. I'm trying to
compare 86,000+ strings in one database against two other databases, each with
over 86,000 entries as well. When I load the other two into arrays, then perform
a binary search of the two arrays, I get 274 "hits" as being missing as compared
to the master. But if I search the the same two databases using a FIND function
(which takes an hour to run) I only get 85 hits. The two arrays are sorted,
which I've double checked with a simple =if(a2<a3.... formula. I just can't
figure it out. My binary search is below
------------------- CODE ----------------------
Function BinarySearch(strArray() As String, strSearch As String) As Long
Dim lngIndex As Long
Dim lngFirst As Long
Dim lngLast As Long
Dim lngMiddle As Long
Dim bolInverseOrder As Boolean
lngFirst = LBound(strArray)
lngLast = UBound(strArray)
bolInverseOrder = (strArray(lngFirst) > strArray(lngLast))
BinarySearch = lngFirst - 1
Do
lngMiddle = (lngFirst + lngLast) \ 2
If strArray(lngMiddle) = strSearch Then
BinarySearch = lngMiddle
Exit Do
ElseIf ((strArray(lngMiddle) < strSearch) Xor bolInverseOrder) Then
lngFirst = lngMiddle + 1
Else
lngLast = lngMiddle - 1
End If
Loop Until lngFirst > lngLast
End Function
------------------- CODE ----------------------
I'll email the file to the moderator so they can post it in the files section.
Thanks for your help.
Scott B)
moderator edit:
The file, called BinarySearchProblem.xlsm has been added to the
Files\Files needing help
section.
[Non-text portions of this message have been removed]
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
Tidak ada komentar:
Posting Komentar