Question

我想用VB在excel中通过单元格的内容在指定文件夹中查找包含此内容的文件，并将文件复制到另一个文件夹中

例如数据区域中有个AAA的内容，我想在指定的文件夹中（例如：D:\My folder\)查找文件名包含AAA的文件，查找到后将文件名包含AAA的文件复制到另一个文件夹（例如：D:\My folder\wen dang\）,并且将没有找到的内容的单元格有标记（比如单元格加颜色等），主要是能识别出来那些内容没有找到和复制，多谢了！

想用VB做个按钮，不知道怎么写！！！
路径提示框如：

非常感谢！！！





Answer 1

比较简单，应该不用多说，如果要查找隐藏文件的话就用我注释掉的那句。

Private Sub CommandButton1_Click()
Call MyFunction("A1", "A14", "D:\新建文件夹")
End Sub

Private Function MyFunction(Range1 As String, Range2 As String, Newpath As String)
Dim OldPath As String
Dim i As Long, j As Long
L1:
OldPath = InputBox("请输入要查找字符的文件夹：", "提示信息")

If StrPtr(OldPath) = 0 Then End '如果点击取消或者关闭按钮 则退出程序
If OldPath = "" Then '判断路径是否为空
MsgBox "请输入路径！", vbOKOnly + vbExclamation, "错误"
GoTo L1

End If

If Dir(OldPath, vbDirectory) = "" Then '判断文件夹是否存在
MsgBox "您输入的文件夹不存在！请重新输入", vbOKOnly + vbExclamation, "错误"
GoTo L1
End If

If Right(OldPath, 1) <> "\" And Right(OldPath, 1) <> ":" Then OldPath = OldPath & "\"
If Right(Newpath, 1) <> "\" And Right(Newpath, 1) <> ":" Then Newpath = Newpath & "\"

For i = Range(Range1).Row To Range(Range2).Row '行 范围
For j = Range(Range1).Column To Range(Range1).Column '列 范围
If Dir(OldPath & Cells(i, j).Value) <> "" Then
'如果要查找包括隐藏文件，就用下面这句
' If Dir(OldPath & Cells(i, j).Value) <> "" OR Dir(OldPath & Cells(i, j).Value,vbhidden)<>"" then
FileCopy OldPath & Cells(i, j).Value, Newpath & Cells(i, j).Value '找到就复制
Else
Cells(i, j).Interior.Color = vbRed '找不到 红色背景
End If
Next
Next

End Function

追问

1、运行时复制命令出现问题，是怎么回事？

加了一个newpath的Inputbox。

2、这个必须单元格内容和文件名一模一样才可以，我想只要包含单元格内容就复制。

追答

还有遍历文件夹的函数我私信给你，这里有字数限制。
Private Sub CommandButton1_Click()
Call MyFunction("A1", "A1000")
End Sub

Private Function MyFunction(Range1 As String, Range2 As String)
Dim OldPath As String, Newpath As String
Dim i As Long, j As Long, k As Long, Arr()
Dim Flag As Boolean
L1:
OldPath = InputBox("请输入要查找字符的文件夹：", "提示信息")
Newpath = InputBox("请输入要复制到的文件夹：", "提示信息")
If StrPtr(OldPath) = 0 Then End '如果点击取消或者关闭按钮 则退出程序

If OldPath = "" Or Newpath = "" Then '判断路径是否为空
MsgBox "请输入路径！", vbOKOnly + vbExclamation, "错误"
GoTo L1
End If

If Dir(OldPath, vbDirectory) = "" Or Dir(Newpath, vbDirectory) = "" Then
MsgBox "您输入的文件夹不存在！请重新输入", vbOKOnly + vbExclamation, "错误"
GoTo L1
End If
If Right(OldPath, 1) "\" And Right(OldPath, 1) ":" Then OldPath = OldPath & "\"
If Right(Newpath, 1) "\" And Right
(Newpath, 1) ":" Then Newpath = Newpath & "\"
Call SearchFiles(OldPath, "*.DWG", Arr()) '获取目录下所有指定类型文件

For i = Range(Range1).Row To Range(Range2).Row '行 范围
For j = Range(Range1).Column To Range(Range1).Column '列 范围
For k = 1 To UBound(Arr)
If InStr(Arr(k), Cells(i, j).Value) Then
FileCopy OldPath & Arr(k), Newpath & Arr(k) '找到就复制
Flag = True
End If
Next
If Not True Then
Cells(i, j).Interior.Color = vbRed '找不到 红色背景
Flag = False
End If
Next
Next

MsgBox "完成！"
End Function

追问

tewulianzhang@163.com
thank you！！！！

Answer 2

这里要说清楚，很困难。
把你的Excel文件发给我：Syx54@sohu.com
两种办法：
一，直接在EXCEL里，加一个按钮。
二，用VB做一个程序。需要指定该Excel文件名？

追问

发过去了，多谢！
最好是在EXCEL里，加一个按钮

追答

没收到 另一个邮箱：Syx54@163.com

追问

我就是想查找A列的单元格内容相应的文件夹的文件，以后需要查找文件直接往这个表格里复制一点按钮就可以
表格发过去了,你自己新建一个表格也可以！

追答

发还给你了，试一下。