CODEWITHSUNDEEP
excelvba
mprtrxprtr
mprtrxprtr

Reputation: 13

Excel VBA binary search to compare columns in one sheet to columns in another and delete the entire row if they match

First time poster so please excuse any faux pas.

I am trying to write a macro in Excel that iterates through about 1000 rows of a sheet ("PLANNING BOARD") and compares the value in column F to a value in column A of another worksheet ("Copy") that contains 500 rows and 20+ columns (values to be compared are integers). If there is a match, I want the entire row to be deleted from the second worksheet and the rows below to be shifted up. I got a linear search to work, but it is very slow, so I am trying implement a binary search.

Here is the binary search function I have:

Function BinarySearch(lookupArray As Variant, lookupValue As Variant) As Integer

 Dim intLower As Integer
 Dim intMiddle As Integer
 Dim intUpper As Integer

 intLower = LBound(lookupArray) 'type mismatch error here 
 intUpper = UBound(lookupArray)

 Do While intLower < intUpper
    intMiddle = (intLower + intUpper) \ 2
    If lookupValue > lookupArray(intMiddle) Then 
        intLower = intMiddle + 1
    Else
        intUpper = intMiddle
    End If
 Loop
 If lookupArray(intLower) = lookupValue Then
    BinarySearch = intLower
 Else
    BinarySearch = -1 'search does not find a match
 End If
End Function

And the calling subroutine:

Sub Compare()

Dim h As Integer

For h = 1 To 1000 'iterate through rows of PLANNING BOARD

     If Sheets("PLANNING BOARD").Cells(h, 6) <> "" Then 'I want to ignore blank cells 

          Dim i As Integer
          i = BinarySearch(Sheets("Copy").Range("A:A"), Sheets("PLANNING BOARD").Cells(h, 6))

            If i <> -1 Then
            'delete row and shift up
            Sheets("Copy").Rows(i).EntireRow.Delete Shift:=xlUp
            End If

     End If

Next h
End Sub

I think there is a problem with the lookupArray that I am passing to the BinarySearch function in the Compare subroutine because I keep getting a type mismatch error when passing the lookupArray to VBA's LBound and UBound functions. Any insight will be greatly appreciated. Thanks.

Upvotes: 1

Views: 1525

Answers (2)

Charles Williams
Charles Williams

Reputation: 23505

I assume your Copy sheet is sorted on column A.

You need to use Long rather than Integer for all your Dim statements.

Also your routine is being extremely inefficient by reading an entire column and then passing it to your binary search routine. Try only passing a the range that actually has any data in it. (You can use either End(Xlup) from below the data or work with the UsedRange).

Lookup Array is 2-dimensional not 1
You need to make sure you have converted the range to a variant array
You can debug this by using the Locals window to determine the type of LookupArray.

Here is an improved version of your code:

Option Explicit

Function BinarySearch(lookupArray As Variant, lookupValue As Variant) As Long

    Dim intLower As Long
    Dim intMiddle As Long
    Dim intUpper As Long

    intLower = LBound(lookupArray)
    intUpper = UBound(lookupArray)

    Do While intLower < intUpper
        intMiddle = (intLower + intUpper) \ 2
        ' lookupArray is 2-dimensional
        If lookupValue > lookupArray(intMiddle, 1) Then
            intLower = intMiddle + 1
        Else
            intUpper = intMiddle
        End If
    Loop
    If lookupArray(intLower, 1) = lookupValue Then
        BinarySearch = intLower
    Else
        BinarySearch = -1    'search does not find a match
    End If
End Function
Sub Compare()

    Dim h As Long
    Dim rngSearched As Range
    Dim lCalcmode As Long
    Dim i As Long

    Application.ScreenUpdating = False
    lCalcmode = Application.Calculation
    Application.Calculation = xlCalculationManual

    For h = 1000 To 1 Step -1    'iterate backwards through rows of PLANNING BOARD
        If Sheets("PLANNING BOARD").Cells(h, 6).Value2 <> "" Then    'I want to ignore blank cells
            ' minimise area being searched
            Set rngSearched = Sheets("Copy").Range("A1:A" & Sheets("Copy").Range("A1048576").End(xlUp).Row)

            i = BinarySearch(rngSearched.Value2, Sheets("PLANNING BOARD").Cells(h, 6).Value2)

            If i <> -1 Then
                ' delete row and shift up
                Sheets("Copy").Rows(i).EntireRow.Delete Shift:=xlUp
            End If

        End If
    Next h

    Application.ScreenUpdating = True
    Application.Calculation = lCalcmode
End Sub

Upvotes: 1

Alex
Alex

Reputation: 1642

When the range being passed to the function BinarySearch(), it is not of type Variant; You can however convert it simply by assigning to one. Please try the following:

Under your function BinarySearch, 

Dim intLower As Integer
Dim intMiddle As Integer
Dim intUpper As Integer
dim temparry as Variant

temparry = lookupArray

intLower = LBound(temparry)

Same for all other use for lookupArray.

Upvotes: 0

Related Questions