怎么查找指定目录中的excel文件中是否存在某一字符

zhaogang1960 · 发表于 2012-2-2 10:25

qdsky 发表于 2012-2-2 09:20
您好，老师，程序应用在附件的例子中是完全正确的，但是今天在单位用于实际数据运行到n = d(arr(i, 6))时 ...

不用n = d(arr(i, 6))了，直接判断字典是否存在：

查找提取_赵老师.rar (22.99 KB, 下载次数: 33)

qdsky · 发表于 2012-2-2 12:24

在运行到If d.Exists(arr(i, 6)) Then语句时还是出现了同样的错误9。我试着重新建立一个目录，其中只含有要查找的字符的文件，结果只运行到With GetObject(arr_File(l))语句就出现了另外一个错误Run-time error"-2147467259(80004005):Automation error,Unspecified error".是我的文件有问题，文件的格式和例子中是一样的，就是名称是类似“1AA123456B01”这样的，或是什么别的原因，还希望老师不要烦我了，再帮帮我。谢谢！

zhaogang1960 · 发表于 2012-2-2 12:57

qdsky 发表于 2012-2-2 12:24
在运行到If d.Exists(arr(i, 6)) Then语句时还是出现了同样的错误9。我试着重新建立一个目录，其中只含有要 ...

估计是文件类型有问题，请上传出错的文件分析一下

zhaogang1960 · 发表于 2012-2-2 23:41

邮件收到，没有测试出问题，修改一句判断F列有数据试试看：

Dim arr_File()
Dim ary(), m As Long, mm As Long
Sub Macro1()
Dim arr, brr(), n, i As Long, sh As Worksheet
Dim fp$, obmapp As Object, d As Object
Set d = CreateObject("scripting.dictionary")
arr = Range("f2:f" & Range("f65536").End(xlUp).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = i
Next
ReDim brr(1 To i - 1, 1 To 4)
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)
If Not obmapp Is Nothing Then
fp = obmapp.Self.Path & ""
Else
Exit Sub
End If
m = 2
ReDim ary(1 To m)
ary(1) = fp
i = 1
Do While ary(i) <> ""
dirdir (ary(i))
i = i + 1
Loop
For Each cel In ary
If cel <> "" Then Call dirf(cel)
Next
Application.ScreenUpdating = False
For l = 1 To mm
With GetObject(arr_File(l))
For Each sh In .Sheets
If sh.[f65536].End(xlUp).Row > 1 Then 'F列有数据
arr = sh.UsedRange
For i = 2 To UBound(arr)
n = d(arr(i, 6))
If n <> "" Then
brr(n, 1) = arr(i, 1)
brr(n, 2) = "N"
brr(n, 4) = arr(i, 4)
End If
Next
End If
Next
.Close False
End With
Next
Range("a2:d65536").ClearContents
[a2].Resize(UBound(brr), 4) = brr
m = 0
mm = 0
Erase ary
Application.ScreenUpdating = True
End Sub
Sub dirdir(MyPath)
Dim MyName
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
m = m + 1
ReDim Preserve ary(1 To m)
ary(m - 1) = MyPath & MyName & ""
End If
End If
MyName = Dir
Loop
End Sub
Sub dirf(My_Path)
MyFileName = Dir(My_Path & "*.xls")
Do While MyFileName <> ""
If InStr(MyFileName, "mm") Then
mm = mm + 1
ReDim Preserve arr_File(1 To mm)
arr_File(mm) = My_Path & MyFileName
End If
MyFileName = Dir
Loop
End Sub

复制代码

qdsky · 发表于 2012-2-3 11:36

谢谢老师不厌其烦的帮助，可能是某些文件有问题，有时还是会出现上面提到的问题，有时又不出现，我也不知道哪里设置不对。但同时我又发现一个新问题，就是如果目标文件中的要查找的字符有重复的话，查找赋值的结果只会显示在最后一行。比如aaa同时在第一和第二行，则运行程序后只会在第二行写入数据，第一行没有变化。还请老师再看看。万分感谢！！！

zhaogang1960 · 发表于 2012-2-3 12:26

qdsky 发表于 2012-2-3 11:36
谢谢老师不厌其烦的帮助，可能是某些文件有问题，有时还是会出现上面提到的问题，有时又不出现，我也不知道 ...

一般字典查询就是这样子，请上传你想要的结果

qdsky · 发表于 2012-2-3 12:41

老师看这样的结果能不能做到？

zhaogang1960 · 发表于 2012-2-3 17:10

qdsky 发表于 2012-2-3 12:41
老师看这样的结果能不能做到？

Dim arr_File()
Dim ary(), m As Long, mm As Long
Sub Macro1()
Dim arr, brr(1 To 60000, 1 To 6), n&, i As Long, sh As Worksheet
Dim fp$, obmapp As Object, d As Object
Set d = CreateObject("scripting.dictionary")
arr = Range("f2:f" & Range("f65536").End(xlUp).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
Next
' ReDim brr(1 To i - 1, 1 To 4)
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)
If Not obmapp Is Nothing Then
fp = obmapp.Self.Path & ""
Else
Exit Sub
End If
m = 2
ReDim ary(1 To m)
ary(1) = fp
i = 1
Do While ary(i) <> ""
dirdir (ary(i))
i = i + 1
Loop
For Each cel In ary
If cel <> "" Then Call dirf(cel)
Next
Application.ScreenUpdating = False
For l = 1 To mm
With GetObject(arr_File(l))
For Each sh In .Sheets
If sh.[f65536].End(xlUp).Row > 1 Then 'F列有数据
arr = sh.UsedRange
For i = 2 To UBound(arr)
' n = d(arr(i, 6))
If d.Exists(arr(i, 6)) Then
n = n + 1
brr(n, 1) = arr(i, 1)
brr(n, 2) = "N"
brr(n, 4) = arr(i, 4)
brr(n, 6) = arr(i, 6)
End If
Next
End If
Next
.Close False
End With
Next
Range("a2:d65536").ClearContents
[a2].Resize(UBound(brr), 6) = brr
m = 0
mm = 0
Erase ary
Application.ScreenUpdating = True
End Sub
Sub dirdir(MyPath)
Dim MyName
MyName = Dir(MyPath, vbDirectory)
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
m = m + 1
ReDim Preserve ary(1 To m)
ary(m - 1) = MyPath & MyName & ""
End If
End If
MyName = Dir
Loop
End Sub
Sub dirf(My_Path)
MyFileName = Dir(My_Path & "*.xls")
Do While MyFileName <> ""
If InStr(MyFileName, "mm") Then
mm = mm + 1
ReDim Preserve arr_File(1 To mm)
arr_File(mm) = My_Path & MyFileName
End If
MyFileName = Dir
Loop
End Sub

复制代码

qdsky · 发表于 2012-2-3 19:32

都不知道用什么词表示感谢了，再次谢谢老师！

qdsky · 发表于 2012-2-8 16:42

本帖最后由 qdsky 于 2012-2-8 16:43 编辑

zhaogang1960 发表于 2012-2-3 17:10

老师，您好，这几天没有仔细测试程序，今天再测试的时候发现了一个问题。运行程序后得到的结果是：将文件的F列更改了，运行吧原文件F列中能查找到的值放到了F列，并且在源文件中查找到几次就重复几次，没找的值就没有了。问题是运行前文件的F列是需要完全保持的，只需根据查找内容赋值它的A，B，D列。F列如有相同的值，需要每行的A，B, D 列都赋值，而不是在指定目录中能找到的次数。我上传了一下运行前后的文件，希望老师能再帮助！谢谢！！！

查找提取test.zip (32.78 KB, 下载次数: 27)

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

[求助] 怎么查找指定目录中的excel文件中是否存在某一字符