Question

第一次发布海报，请原谅任何失礼。

我正在尝试在Excel中编写一个宏来迭代大约1000行的工作表（“PLANNING BOARD”），并将F列中的值与包含在另一个工作表（“Copy”）的A列中的值进行比较500行和20+列（要比较的值是整数）。如果匹配，我希望从第二个工作表中删除整行，并将下面的行向上移动。我有一个线性搜索工作，但它很慢，所以我正在尝试实现二进制搜索。

这是我的二进制搜索功能：

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

调用子程序：

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

我认为lookupArray存在一个问题，我在Compare子例程中传递给BinarySearch函数，因为在将lookupArray传递给VBA的LBound和UBound函数时，我一直遇到类型不匹配错误。任何见解将不胜感激。谢谢。

Answer 1

我认为你的复制表在A栏上排序。

您需要对所有Dim语句使用Long而不是Integer。

通过读取整个列然后将其传递给二进制搜索例程，您的例程效率极低。尝试仅传递实际包含任何数据的范围。（您可以使用数据下方的End（Xlup）或使用UsedRange。）

查找数组是2维而不是1 您需要确保已将范围转换为变量数组
您可以使用Locals窗口来调试它，以确定LookupArray的类型。

以下是代码的改进版本：

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

Answer 2

当range传递给函数BinarySearch（）时，它不是Variant类型;但是，您可以通过分配一个来转换它。请尝试以下方法：

在你的函数BinarySearch下，

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

temparry = lookupArray

intLower = LBound(temparry)

lookupArray的所有其他用途相同。

Excel VBA二进制搜索将一个工作表中的列与另一个工作表中的列进行比较，如果匹配则删除整个行

2 个答案: