怎么实现模糊查询

wangjin1982_0 · 发表于 2014-5-19 17:09

我编写了一个excel的查询，但是只能实现完全匹配的查询。我想实现模糊查询，怎么实现？例如，在下面的附件里面可以看到有“宏达新材料”，如果我希望在查询里面只输入“宏达”就可以查到，怎么实现？
望高手赐教。

日常销售汇总模板.rar (41.19 KB, 下载次数: 524)

cbtaja · 发表于 2014-5-19 18:25

Sub mhcx()
findchar = Sheets("查询").Range("a2")
arr = Sheet1.Range("A1").CurrentRegion
r = UBound(arr)
ReDim brr(1 To r, 1 To 13)
For i = 2 To r
If InStr(1, arr(i, 2), findchar) > 0 Or InStr(1, arr(i, 3), findchar) > 0 Then
p = p + 1
For j = 1 To 13
brr(p, j) = IIf(j > 3, arr(i, j + 2), arr(i, j))
Next
End If
Next
Sheets("查询").UsedRange.Offset(4).Delete
If p > 0 Then
With Sheets("查询").[a5].Resize(p, 13)
.Value = brr
.Font.Name = "arial"
.Font.Size = 9
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders.ColorIndex = 23
End With
End If
End Sub

复制代码

wangjin1982_0 · 发表于 2014-5-20 15:21

cbtaja 发表于 2014-5-19 18:25

非常感谢！太有用了。

wangjin1982_0 · 发表于 2014-5-20 17:40

cbtaja 发表于 2014-5-19 18:25

我发现另外一个问题，如果搜索内容为空，那么会把整个表全部列出来。这要这么改？我希望如果搜索条件为空的时候，结果也为空。

wangjin1982_0 · 发表于 2014-5-20 18:01

在执行的时候，有提示 brr(p, j) = IIf(j > 3, arr(i, j + 2), arr(i, j)) 下标越界。我设置 For j = 1 To 11，结果每一行记录的第三个电话内容会写到联系人上去。都错位了，这么办？

cbtaja · 发表于 2014-5-21 10:26

wangjin1982_0 发表于 2014-5-20 18:01
在执行的时候，有提示 brr(p, j) = IIf(j > 3, arr(i, j + 2), arr(i, j)) 下标越界。我设置 For j = 1 T ...

请将出现问题的表格发上来看看。

wangjin1982_0 · 发表于 2014-5-22 10:37

cbtaja 发表于 2014-5-21 10:26
请将出现问题的表格发上来看看。

请看附件的表格。我是将所提供的代码直接放在最后运行的。如果不改代码直接操作，会提示brr(p, j) = IIf(j > 3, arr(i, j + 2), arr(i, j))这行下标越界，具体是在arr(i, j + 2)上。按照提示我试着把上一行的 For j = 1 To 13改成 For j = 1 To 11，可以直接运行，但是出现的结果是查询的表格里面办公电话跑到联系人里面去了，而且后面的数据也都依次往前调整了两列。
请指教

日常销售汇总0516 - 副本.rar (34.53 KB, 下载次数: 131)

wangjin1982_0 · 发表于 2014-5-22 11:27

好像我把brr(p, j) = IIf(j > 3, arr(i, j + 2), arr(i, j))改成brr(p, j) = IIf(j > 3, arr(i, j), arr(i, j))，问题就解决了。有什么后遗症吗？

cbtaja · 发表于 2014-5-22 12:57

1、你实际的表格与此前提供的表格相比，其《所有客户》工作表中删除了“感兴趣产品”、“预计点数”两列，程序当然需要相应变化，否则岂不是成了刻舟求剑了！
2、我给出的是一个完整的独立程序，不需要插入到其它程序中。而且可以更快！
3、修改后的代码是：

Sub mhcx()
findchar = Sheets("查询").Range("a2")
arr = Sheet1.Range("A1").CurrentRegion
r = UBound(arr)
ReDim brr(1 To r, 1 To 13)
For i = 2 To r
If InStr(1, arr(i, 2), findchar) > 0 Then
p = p + 1
For j = 1 To 13
brr(p, j) = arr(i, j)
Next
End If
Next
Sheets("查询").UsedRange.Offset(4).Delete
If p > 0 Then
With Sheets("查询").[a5].Resize(p, 13)
.Value = brr
.Font.Name = "arial"
.Font.Size = 9
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders.ColorIndex = 23
End With
End If
End Sub

复制代码

cbtaja · 发表于 2014-5-22 12:58

日常销售汇总0516 - 副本.rar (28.52 KB, 下载次数: 698)

		自动登录	找回密码
密码			免费注册