如何用vba实现模糊查找

郁孤亭

模糊查找.rar (119.58 KB, 下载次数: 885)

2012-7-30 22:14 上传

点击文件名下载附件

b列为姓名
a列为姓名的首字母缩写
c1为要查找的目标
需要在a列中模糊查找c1，在d列返回查找结果，并按照匹配程度排序
我想用i遍历a列，用search（c1,a,1)的返回值来判断匹配度，用d[j]记录结果（d[j]=b)
用e[j]=search（c1,a,1)来记录匹配度
然后对d列e列进行排序
不知可行否？
用录制宏的方法以及实现，但d=b,需要对太多列进行排序。

我基本不会vba，写的代码到search公式总是出错
Dim i, j As Integer
j = 2
For i = 2 To 10202
On Error Resume Next
If Excel.WorksheetFunction.IsErr(Excel.WorksheetFunction.Search([d1], Cells(i, 1), 1)) = False Then
If Excel.WorksheetFunction.Search([d1], Cells(i, 1), 1) = 1 And Excel.WorksheetFunction.Len(Cells(i, 1)) = Excel.WorksheetFunction.Len([d1]) Then
Cells(j, 6) = 1
Cells(j, 5) = Cells(i, 2)
j = j + 1
Else
Cells(j, 6) = 2
Cells(j, 5) = Cells(i, 2)
j = j + 1
End If
End If
Next

请大家看看问题出在哪里？
有没有完成的代码？xiexie

zhaogang1960

有好几种方法：数组发、Find法、ADO法等，下面是ADO法请参考：
Sub Macro1()
    Dim cnn As Object, SQL$
    Set cnn = CreateObject("ADODB.Connection")
    cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties =Excel 8.0;Data Source =" & ThisWorkbook.FullName
    SQL = "Select 姓名 from [Sheet1$a1:b] where 首字母 like '%" & [C1] & "%'"
    Range("d2:d65536").ClearContents
    [d2].CopyFromRecordset cnn.Execute(SQL)
    cnn.Close
    Set cnn = Nothing
End Sub

zhaogang1960

1. Sub Find法()
   
2.     Dim c As Range, firstAddress$, arr(), m&
   
3.     ReDim arr(1 To [a65536].End(xlUp).Row, 1 To 1)
   
4.     With Range("a:a")
   
5.         Set c = .Find([c1], , , 2)
   
6.         If Not c Is Nothing Then
   
7.             firstAddress = c.Address
   
8.             Do
   
9.                 m = m + 1
   
10.                 arr(m, 1) = c.Offset(, 1)
    
11.                 Set c = .FindNext(c)
    
12.             Loop While Not c Is Nothing And c.Address <> firstAddress
    
13.         End If
    
14.     End With
    
15.     Range("d2:d65536").ClearContents
    
16.     If m > 0 Then [d2].Resize(m) = arr
    
17. End Sub
    
18. 
    

复制代码

郁孤亭

zhaogang1960 发表于 2012-7-30 22:45

谢谢
关于find的介绍，哪里能找到呢？
看了这个find和excel的find公式不同
在vb的帮助里也找不到

zhaogang1960

数组法：
Sub 数组法()
    Dim arr, brr(), i&, m&, s$
    s = [c1]
    arr = Range("a2:b" & [a65536].End(xlUp).Row)
    ReDim brr(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        If InStr(arr(i, 1), s) Then
            m = m + 1
            brr(m, 1) = arr(i, 2)
        End If
    Next
    Range("d2:d65536").ClearContents
    If m > 0 Then [d2].Resize(m) = brr
End Sub

zhaogang1960

郁孤亭 发表于 2012-7-30 22:53
谢谢
关于find的介绍，哪里能找到呢？
看了这个find和excel的find公式不同

VBA帮助


Find 方法

应用于 Range 对象的 Find 方法。

zhaogang1960

请看附件
模糊查找.rar (127.85 KB, 下载次数: 4258)

2012-7-30 23:05 上传

点击文件名下载附件

骑着蜗牛去兜风

学习学习!{:soso_e100:}

yangyangzhifeng

试试

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Address <> "$C$1" Then Exit Sub
   
3.     Dim arr, brr, i&, x&
   
4.     i = Target.Offset(65535, -2).End(xlUp).Row
   
5.     arr = Target.Offset(1, -2).Resize(i - 1, 2)
   
6.     ReDim brr(1 To UBound(arr), 1 To 2)
   
7.     For i = 1 To UBound(arr)
   
8.         If InStr(1, arr(i, 1), Target.Value) > 0 Then
   
9.             x = x + 1
   
10.             brr(x, 1) = arr(i, 2)
    
11.             brr(x, 2) = InStr(1, arr(i, 1), Target.Value)
    
12.         End If
    
13.     Next
    
14.     Target.Offset(1, 1).Resize(UBound(arr), 2) = brr
    
15.     Target.Offset(1, 1).Resize(UBound(arr), 2).Sort key1:=Target.Offset(1, 2), order1:=xlAscending
    
16. End Sub
    

复制代码

郁孤亭

zhaogang1960 发表于 2012-7-30 23:05
请看附件

多谢高手指点。
学习中