[已解决]大海捞针（查找问题）难度挺大

qhllqhll

本例在实际中挺有用的
请求各位老师们忙看否能用vba达到我的要求，要求在附件里，
谢谢
大海捞针.rar (21.67 KB, 下载次数: 18)

2013-9-1 15:14 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-9-1 17:07

查找.rar (19.04 KB, 下载次数: 16)

2013-9-1 17:07 上传

点击文件名下载附件

工作中还是尽量少用合并单元格吧。

跳转到最佳答案楼层

hwc2ycy

查找的时候用模糊匹配吧。

hwc2ycy

不知道是你B4单元格里输入了空格还是要查的工作表里输入了空格。
直接把空格替换，匹配不就成了嘛。

qhllqhll

hwc2ycy 发表于 2013-9-1 16:06
不知道是你B4单元格里输入了空格还是要查的工作表里输入了空格。
直接把空格替换，匹配不就成了嘛。

烟花版主您好：b4里的空格就不用管了
这是个大难题 还得有劳您的出手
谢谢
期待您的解决{:1112:}

上清宫主

查找：
Sub test()
Dim wb As Workbook, sh As Worksheet, c As Range, ar()
If Trim([b4]) = "" Then Exit Sub
s$ = Trim([b4])
fp$ = ThisWorkbook.Path & "\资料\"
fn$ = Dir(fp & "*.xls*")
ReDim ar(1 To 2)
Application.ScreenUpdating = 0
Do While fn <> ""
   Set wb = Workbooks.Open(fp & fn)
   For Each sh In wb.Worksheets
       Set c = sh.Cells.Find(s)
       If Not c Is Nothing Then
          r = r + 1
          If r > UBound(ar) Then ReDim Preserve ar(1 To r + 100)
          ar(r) = fp & fn & "\" & sh.Name
        End If
   Next
   wb.Close 0
   fn$ = Dir
Loop
Range("a9:f" & [a65536].End(3).Row).ClearContents
[a9].Resize(r, 1) = Application.Transpose(ar)
End Sub

单元格事件：
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column > 1 Then Exit Sub
If Target.Row < 9 Then Exit Sub
s = Target(1).Text
If s = "" Then Exit Sub
Set wb = Workbooks.Open(Left(s, InStrRev(s, "\") - 1))
wb.Sheets(Mid(s, InStrRev(s, "\") + 1)).Select
End Sub

hwc2ycy

查找.rar (19.04 KB, 下载次数: 16)

2013-9-1 17:07 上传

点击文件名下载附件

工作中还是尽量少用合并单元格吧。