[已解决]求助：模糊查找有个问题要解决

zgm1201

FCpcKlC3.rar (49.77 KB, 下载次数: 16)

2010-2-22 13:00 上传

点击文件名下载附件
求助：模糊查找有个问题要解决

最佳答案

月排行榜 / 总排行榜

枯禅

2010-2-22 13:18

猜了一个你的意思，估计是：

Sub 模糊查找()    '薄内快速模糊查找
    On Error Resume Next
    Dim Flag As Boolean, arr, I&, J&
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With Sheets("基本信息输入")
        arr = .Range("A11:R" & .[A65536].End(xlUp).Row)
   End With
    With Sheets("电话簿")
            For I = LBound(arr) To UBound(arr)
            If arr(I, 1) = "" Then arr(I, 1) = arr(I - 1, 1)
            For J = 2 To UBound(arr, 2)
                If arr(I, J) Like "*" & .[E6].Value & "*" Then
                    Flag = True
                    Exit For
                Else
                    Flag = False
                End If
            Next
            If Not Flag Then arr(I, 1) = "=1/0"
        Next
        .[B9:M65536] = ""
        .[B9].Resize(UBound(arr), UBound(arr, 2)) = arr
        .[B9].Resize(UBound(arr), 1).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
    End With
    Application.EnableEvents = True
End Sub

PS：但我不认为这个是最好的

跳转到最佳答案楼层

枯禅

猜了一个你的意思，估计是：

Sub 模糊查找()    '薄内快速模糊查找
    On Error Resume Next
    Dim Flag As Boolean, arr, I&, J&
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With Sheets("基本信息输入")
        arr = .Range("A11:R" & .[A65536].End(xlUp).Row)
   End With
    With Sheets("电话簿")
            For I = LBound(arr) To UBound(arr)
            If arr(I, 1) = "" Then arr(I, 1) = arr(I - 1, 1)
            For J = 2 To UBound(arr, 2)
                If arr(I, J) Like "*" & .[E6].Value & "*" Then
                    Flag = True
                    Exit For
                Else
                    Flag = False
                End If
            Next
            If Not Flag Then arr(I, 1) = "=1/0"
        Next
        .[B9:M65536] = ""
        .[B9].Resize(UBound(arr), UBound(arr, 2)) = arr
        .[B9].Resize(UBound(arr), 1).SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
    End With
    Application.EnableEvents = True
End Sub

PS：但我不认为这个是最好的

amulee

稍微简化了一下代码

Sub 模糊查找()    '薄内快速模糊查找
    On Error Resume Next
    Dim arr, I&, J&, N&
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With Sheets("基本信息输入")
        arr = .Range("A11:R" & .[A65536].End(xlUp).Row)
    End With
    N = 9
    With Sheets("电话簿")
        .[B9:M65536].Clear
        For I = LBound(arr) To UBound(arr)
            If arr(I, 1) = "" Then arr(I, 1) = arr(I - 1, 1)
            For J = 2 To UBound(arr, 2)
                If arr(I, J) Like "*" & .[E6].Value & "*" Then
                    .Range("B" & N).Resize(1, UBound(arr, 2)) = WorksheetFunction.Index(arr, I, 0)
                    N = N + 1
                    Exit For
                End If
            Next
        Next
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

fjmxwrs

应该是代码，我看不明白来学习

fjmxwrs

QUOTE:

以下是引用amulee在2010-2-22 13:48:00的发言：

稍微简化了一下代码

Sub 模糊查找()    '薄内快速模糊查找
    On
  Error
  Resume
  Next
    Dim arr, I&, J&, N&
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With Sheets("基本信息输入")
        arr = .Range("A11:R" & .[A65536].End(xlUp).Row)
    End
  With
    N = 9
    With Sheets("电话簿")
        .[B9:M65536].Clear
        For I = LBound(arr) To
  UBound(arr)
            If arr(I, 1) = "" Then arr(I, 1) = arr(I - 1, 1)
            For J = 2 To
  UBound(arr, 2)
                If arr(I, J) Like "*" & .[E6].Value & "*" Then
                    .Range("B" & N).Resize(1, UBound(arr, 2)) = WorksheetFunction.Index(arr, I, 0)
                    N = N + 1
                    Exit
  For
                End
  If
            Next
        Next
    End
  With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

我把这代码替换原来的代码后，查询后，我把电话簿里的内容都清除了，再查应该是没有数据的，可单位地址后面的几个项目的数据不动了，前面查过的，一直保留下来了，何故？

[此贴子已经被作者于2010-2-22 14:47:11编辑过]

fjmxwrs

二楼的试过了，应该是楼主想要的吧？

zgm1201

QUOTE:

以下是引用fjmxwrs在2010-2-22 14:43:00的发言：

我把这代码替换原来的代码后，查询后，我把电话簿里的内容都清除了，再查应该是没有数据的，可单位地址后面的几个项目的数据不动了，前面查过的，一直保留下来了，何故？

把[B9:M65536].Clear改成[B9:S65536].Clear就可以了

zgm1201

QUOTE:

以下是引用amulee在2010-2-22 13:48:00的发言：

稍微简化了一下代码

Sub 模糊查找()    '薄内快速模糊查找
    On
  Error
  Resume
  Next
    Dim arr, I&, J&, N&
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    With Sheets("基本信息输入")
        arr = .Range("A11:R" & .[A65536].End(xlUp).Row)
    End
  With
    N = 9
    With Sheets("电话簿")
        .[B9:M65536].Clear
        For I = LBound(arr) To
  UBound(arr)
            If arr(I, 1) = "" Then arr(I, 1) = arr(I - 1, 1)
            For J = 2 To
  UBound(arr, 2)
                If arr(I, J) Like "*" & .[E6].Value & "*" Then
                    .Range("B" & N).Resize(1, UBound(arr, 2)) = WorksheetFunction.Index(arr, I, 0)
                    N = N + 1
                    Exit
  For
                End
  If
            Next
        Next
    End
  With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

谢谢！帮我简化代码。