VBA关于多工作簿查询包含指定的字符的应用（很难的）

zhouxiao · 发表于 2012-8-15 13:00

kevinchengcw 发表于 2010-10-28 20:32
Sub test()
Dim Dic, Wb As Workbook, Ws As Worksheet, Arr, N&, FN$, Str$, Rng As Range
Set Dic = Cr ...

kevinchengcw老师,您好
我的工作和楼主的工作内容很像,但我只需要被查询字符所在的工作表名(如果是重复的工作表名,我只需要它出现1次).您的代码应该怎样进行修改,请您抽空给我指导一下,谢谢

PS:前两天我发了张贴,little key版主建议我用VBA遍历工作簿中的内容,返回工作簿名称,这两天一直在想怎么编这些代码,今天有幸正好搜索到您关于这类问题的回复.我刚学VBA不久,知道用VBA实现,但不知道代码怎么编,呵,很多初学者的弊病.最后附带我前天提出的问题的帖,希望您给予指导,谢谢http://club.excelhome.net/thread-905702-1-1.html

kevinchengcw · 发表于 2012-8-15 14:12

zhouxiao 发表于 2012-8-15 13:00
kevinchengcw老师,您好
我的工作和楼主的工作内容很像,但我只需要被查询字符所在的工作表名(如果是重复的 ...

Sub test()
Dim Dic As Object, Ws As Worksheet, Arr, Arr2, Result, N&, I!, FN$, Str$, Str2$
Set Dic = CreateObject("scripting.dictionary")
Str = InputBox("查找内容:", "输入")
If Str = "" Then Exit Sub
Application.ScreenUpdating = False
FN = Dir(ThisWorkbook.Path & "\*.xls?")
Do While FN <> ""
If FN <> ThisWorkbook.Name Then
With GetObject(ThisWorkbook.Path & "" & FN)
For Each Ws In .Worksheets
Set Rng = Ws.Cells.Find(Str)
If Not Rng Is Nothing Then
Str2 = Left(.Name, InStrRev(.Name, ".") - 1) & vbTab & Ws.Name & vbTab & Rng.Value
If Not Dic.exists(Str2) Then Dic(Str2) = ""
Set Rng = Nothing
End If
Next Ws
.Close False
End With
End If
FN = Dir
Loop
With Worksheets("查询")
.Rows("3:" & .Rows.Count).Clear
If Dic.Count > 0 Then
Arr = Dic.keys
ReDim Result(1 To Dic.Count, 1 To 3)
For N = LBound(Arr) To UBound(Arr)
Arr2 = Split(Arr(N), vbTab)
For I = LBound(Arr2) To UBound(Arr2)
Result(N + 1, I + 1) = Arr2(I)
Next I
Next N
With .[a3].Resize(UBound(Dic.Count, 3))
.Value = Result
.Borders.LineStyle = 1
End With
MsgBox "查找完成"
Else
MsgBox "不存在你要搜索的内容"
End If
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

复制代码

是这个意思吗？

zhouxiao · 发表于 2012-8-15 14:15

kevinchengcw 发表于 2012-8-15 14:12
是这个意思吗？

谢谢您,我先试一上看

zhouxiao · 发表于 2012-8-15 15:15

本帖最后由 zhouxiao 于 2012-8-15 15:16 编辑

kevinchengcw 发表于 2012-8-15 14:12
是这个意思吗？

老师,您好,您修改后的代码我试过了,到with .[a3].resize(ubound(dic.count,3))这句的时候,类型不匹配,报错(见下图)
报错.jpg

下面这张图片是我要的结果,用您修改前的代码运行的结果,总共有708行数据
但我只需要其中的30行数据,因为其它的文件名都是重复的,如下图(我删除重复项以后的结果)
查询结果2.jpg

kevinchengcw · 发表于 2012-8-15 16:54

With .[a3].Resize(UBound(Dic.Count, 3))

复制代码

手误，应为

With .[a3].Resize(Dic.Count, 3)

复制代码

工作表名重复还是工作簿名重复？

zhouxiao · 发表于 2012-8-17 09:08

kevinchengcw 发表于 2012-8-15 16:54
手误，应为工作表名重复还是工作簿名重复？

工作簿名重复

kevinchengcw · 发表于 2012-8-17 09:57

Sub test()
Dim Dic As Object, Ws As Worksheet, Arr, Arr2, Result, N&, I!, FN$, Str$, Str2$
Set Dic = CreateObject("scripting.dictionary")
Str = InputBox("查找内容:", "输入")
If Str = "" Then Exit Sub
Application.ScreenUpdating = False
FN = Dir(ThisWorkbook.Path & "\*.xls?")
Do While FN <> ""
If FN <> ThisWorkbook.Name Then
With GetObject(ThisWorkbook.Path & "" & FN)
For Each Ws In .Worksheets
Set Rng = Ws.Cells.Find(Str)
If Not Rng Is Nothing Then
Str2 = Left(.Name, InStrRev(.Name, ".") - 1)
Dic(Str2) = ""
Set Rng = Nothing
End If
Next Ws
.Close False
End With
End If
FN = Dir
Loop
With Worksheets("查询")
.Rows("3:" & .Rows.Count).Clear
If Dic.Count > 0 Then
With .[a3].Resize(Dic.Count)
.Value = Application.Transpose(Dic.keys)
.Borders.LineStyle = 1
End With
MsgBox "查找完成"
Else
MsgBox "不存在你要搜索的内容"
End If
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

复制代码

试这个

zhouxiao · 发表于 2012-8-17 13:56

kevinchengcw 发表于 2012-8-17 09:57
试这个

老师辛苦了,谢谢

工作状态 · 发表于 2012-8-25 09:20

本帖最后由工作状态于 2012-8-25 09:42 编辑

kevinchengcw 发表于 2012-8-17 09:57
试这个

太谢谢kevinchengcw老师了，这个方法解决了工作中很大的劳动量，十分感谢！我和楼主遇到的问题很相像，但是比楼主多一个工作内容，就是要把包含关键字符所在的整行也提取出来。kevinchengcw老师可不可以教一下怎么在满足楼主现有要求的前提下，即在序号-工作簿名-工作表名-单元格地址-单元格内容后面把关键字符所在的整行也提取出来。至于备注，就不需要了，因为现在提取整行，已经把原来网友增加备注功能（后2个单元格内容）满足了。工作中大量需要，求kevinchengcw老师指点！万分感谢！

kevinchengcw · 发表于 2012-8-25 10:09

工作状态发表于 2012-8-25 09:20
太谢谢kevinchengcw老师了，这个方法解决了工作中很大的劳动量，十分感谢！我和楼主遇到的问题很相像，但 ...

试下附件

工作簿1.rar (19.53 KB, 下载次数: 141)

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

[求助] VBA关于多工作簿查询包含指定的字符的应用（很难的）

评分