Vba在特定文件夹含子文件夹中查找名称包含“一个”的excle表并复制到新地址
时间: 2023-08-02 10:05:48 浏览: 55
好的,根据您的需求,我为您编写了以下 VBA 代码,可以在特定文件夹及其子文件夹中查找名称包含“一个”的 Excel 表,并将其复制到新地址:
```vb
Sub FindAndCopyExcelFiles()
Dim sourceFolder As String
Dim targetFolder As String
Dim fileName As String
Dim fileExt As String
Dim sourceFilePath As String
Dim targetFilePath As String
Dim found As Boolean
sourceFolder = "C:\YourSourceFolderPath\" '替换成您要查找的文件夹路径
targetFolder = "C:\YourTargetFolderPath\" '替换成您要复制到的新地址
'检查目标文件夹是否存在,如果不存在则创建
If Dir(targetFolder, vbDirectory) = "" Then
MkDir targetFolder
End If
'遍历源文件夹及其子文件夹
fileName = Dir(sourceFolder & "*.*", vbDirectory)
Do While fileName <> ""
If fileName <> "." And fileName <> ".." Then
'检查是否为文件夹
If (GetAttr(sourceFolder & fileName) And vbDirectory) = vbDirectory Then
'递归遍历子文件夹
FindAndCopyExcelFilesRecursive sourceFolder & fileName & "\", targetFolder, found
Else
'检查文件名是否包含“一个”,并且文件类型为 Excel 表格
fileExt = Right(fileName, Len(fileName) - InStrRev(fileName, "."))
If InStr(1, fileName, "一个", vbTextCompare) > 0 And fileExt = "xlsx" Then
sourceFilePath = sourceFolder & fileName
targetFilePath = targetFolder & fileName
'复制文件
FileCopy sourceFilePath, targetFilePath
found = True
End If
End If
End If
'获取下一个文件名
fileName = Dir()
Loop
If Not found Then
MsgBox "No Excel files found."
Else
MsgBox "Excel files copied successfully."
End If
End Sub
Sub FindAndCopyExcelFilesRecursive(ByVal folderPath As String, ByVal targetFolder As String, ByRef found As Boolean)
Dim fileName As String
Dim fileExt As String
Dim sourceFilePath As String
Dim targetFilePath As String
fileName = Dir(folderPath & "*.*", vbDirectory)
Do While fileName <> ""
If fileName <> "." And fileName <> ".." Then
'检查是否为文件夹
If (GetAttr(folderPath & fileName) And vbDirectory) = vbDirectory Then
'递归遍历子文件夹
FindAndCopyExcelFilesRecursive folderPath & fileName & "\", targetFolder, found
Else
'检查文件名是否包含“一个”,并且文件类型为 Excel 表格
fileExt = Right(fileName, Len(fileName) - InStrRev(fileName, "."))
If InStr(1, fileName, "一个", vbTextCompare) > 0 And fileExt = "xlsx" Then
sourceFilePath = folderPath & fileName
targetFilePath = targetFolder & fileName
'复制文件
FileCopy sourceFilePath, targetFilePath
found = True
End If
End If
End If
'获取下一个文件名
fileName = Dir()
Loop
End Sub
```
在代码中,我们定义了两个子程序。`FindAndCopyExcelFiles` 程序用于遍历指定文件夹及其子文件夹并查找包含“一个”的 Excel 表格,并将其复制到新地址;而 `FindAndCopyExcelFilesRecursive` 程序则用于递归遍历子文件夹。
您只需要将代码中的 `sourceFolder` 和 `targetFolder` 变量替换成您要查找的文件夹路径和要复制到的新地址,然后执行 `FindAndCopyExcelFiles` 程序即可。程序会提示您查找到了多少个 Excel 文件,并将符合要求的 Excel 文件复制到新地址。如果没有找到任何文件,则会弹出提示框“No Excel files found.”。