从多个子文件夹复制文件的VBA宏
我有一个VBA用于根据图像名称将图像从一个文件夹复制到另一个文件夹。您可以在“附件”中的“工作”中检查宏。代码是:从多个子文件夹复制文件的VBA宏,vba,Vba,我有一个VBA用于根据图像名称将图像从一个文件夹复制到另一个文件夹。您可以在“附件”中的“工作”中检查宏。代码是: Option Explicit Sub CopyFiles() Dim iRow As Integer ' ROW COUNTER. Dim sSourcePath As String Dim sDestinationPath As String Dim sFileType As String Dim bContinue
Option Explicit
Sub CopyFiles()
Dim iRow As Integer ' ROW COUNTER.
Dim sSourcePath As String
Dim sDestinationPath As String
Dim sFileType As String
Dim bContinue As Boolean
bContinue = True
iRow = 2
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"
sFileType = ".jpg" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
' LOOP THROUGH COLUMN "A" TO PICK THE FILES.
While bContinue
If Len(Range("A" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
MsgBox "Images have been moved. Thank you!" ' DONE.
bContinue = False
Else
' CHECK IF FILES EXISTS.
If Len(Dir(sSourcePath & Range("A" & CStr(iRow)).Value & sFileType)) = 0 Then
Range("B" & CStr(iRow)).Value = "Does Not Exists"
Range("B" & CStr(iRow)).Font.Bold = True
Else
Range("B" & CStr(iRow)).Value = "On Hand"
Range("B" & CStr(iRow)).Font.Bold = False
If Trim(sDestinationPath) <> "" Then
Dim objFSO
Set objFSO = CreateObject("scripting.filesystemobject")
' CHECK IF DESTINATION FOLDER EXISTS.
If objFSO.FolderExists(sDestinationPath) = False Then
MsgBox sDestinationPath & " Does Not Exists"
Exit Sub
End If
'*****
' HERE I HAVE INCLUDED TWO DIFFERENT METHODS.
' I HAVE COMMENTED THE SECOND METHOD. TO THE SEE THE RESULT OF THE
' SECOND METHOD, UNCOMMENT IT AND COMMENT THE FIRST METHOD.
' METHOD 1) - USING "CopyFile" METHOD TO COPY THE FILES.
objFSO.CopyFile Source:=sSourcePath & Range("A" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
' METHOD 2) - USING "MoveFile" METHOD TO PERMANENTLY MOVE THE FILES.
'objFSO.MoveFile Source:=sSourcePath & Range("B" & CStr(iRow)).Value & _
sFileType, Destination:=sDestinationPath
'*****
End If
End If
End If
iRow = iRow + 1 ' INCREMENT ROW COUNTER.
Wend
End Sub
选项显式
子复制文件()
Dim iRow作为整数行计数器。
将sSourcePath设置为字符串
Dim sDestinationPath作为字符串
将sFileType设置为字符串
Dim b作为布尔值继续
b继续=真
iRow=2
'具有路径的源文件夹和目标文件夹。
sSourcePath=“C:\Users\nhatc\u 000\Desktop\01010101”
sDestinationPath=“C:\Users\nhatc\u 000\Desktop\020202”
sFileType=“.jpg”尝试使用其他文件类型,如“.pdf”。
'循环通过列“A”来选择文件。
继续
如果Len(Range(“A”)和CStr(iRow)).Value=0,则“如果列为空,则不执行任何操作”。
MsgBox“图像已被移动。谢谢!”“完成。
b继续=错误
其他的
'检查文件是否存在。
如果Len(Dir(sSourcePath&Range(“A”&CStr(iRow)).Value&sFileType))=0,则
范围(“B”和CStr(iRow)).Value=“不存在”
范围(“B”和CStr(iRow))。Font.Bold=True
其他的
范围(“B”和CStr(iRow)).Value=“现有”
范围(“B”和CStr(iRow))。Font.Bold=False
如果修剪(sDestinationPath)“,则
Dim objFSO
设置objFSO=CreateObject(“scripting.filesystemobject”)
'检查目标文件夹是否存在。
如果objFSO.FolderExists(sDestinationPath)=False,则
MsgBox sdestinitionpath&“不存在”
出口接头
如果结束
'*****
在这里,我介绍了两种不同的方法。
“我已经对第二种方法进行了评论。以查看测试结果
'第二个方法,取消注释它并注释第一个方法。
'方法1)-使用“CopyFile”方法复制文件。
objFSO.CopyFile源:=sSourcePath和Range(“A”和CStr(iRow)).Value和_
sFileType,目标:=sDestinationPath
'方法2)-使用“MoveFile”方法永久移动文件。
'objFSO.MoveFile Source:=sSourcePath和Range(“B”和CStr(iRow)).Value和_
sFileType,目标:=sDestinationPath
'*****
如果结束
如果结束
如果结束
iRow=iRow+1'增量行计数器。
温德
端接头
但是,我还需要向该代码中添加两个内容:
谢谢 您需要的是一些递归sub,以便根据范围值查找所有相似的文件名 在这里,我将通过以下代码通过几个步骤实现这一目标:
Option Explicit
' THE SOURCE AND DESTINATION FOLDER WITH PATH.
Private Const sSourcePath = "C:\Users\nhatc_000\Desktop\01010101\"
Private Const sDestinationPath = "C:\Users\nhatc_000\Desktop\02020202\"
Private Const sFileType = "jpg" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
Private Const DIV = "|" ' A character that's not legal file name
Private objFSO As Object, objDict As Object
Sub CopyFilesAlike()
Dim lRow As Long, sName As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(sSourcePath) Then
MsgBox "Source folder not found!" & vbCrLf & sSourcePath, vbCritical + vbOKOnly
GoTo I_AM_DONE
End If
If Not objFSO.FolderExists(sDestinationPath) Then
MsgBox "Destination folder not found!" & vbCrLf & sDestinationPath, vbCritical + vbOKOnly
GoTo I_AM_DONE
End If
' Proceed when both Source and Destination folders found
Set objDict = CreateObject("Scripting.Dictionary")
lRow = 2
Do Until IsEmpty(Cells(lRow, "A")) ' Stop on first empty cell in Column A from lRow
' Get Main file name to look up
sName = Cells(lRow, "A").Value
' Look for files (exact and alikes from sub folders) to add to dictionary
LookForFilesAlike sName, objFSO.GetFolder(sSourcePath)
' Copy files
If objDict.Count = 0 Then
Cells(lRow, "B").Value = "No files found."
Else
Cells(lRow, "B").Value = objDict.Count & " filenames(s) found." & vbLf & CopyFiles
End If
' Clear the Dictionary for next Name
objDict.RemoveAll
' Increment row counter
lRow = lRow + 1
Loop
Set objDict = Nothing
I_AM_DONE:
Set objFSO = Nothing
End Sub
Private Sub LookForFilesAlike(ByVal sName As String, ByVal objFDR As Object)
Dim oFile As Object, oFDR As Object
' Add files of current folder to dictionary if name matches
For Each oFile In objFDR.Files
If InStr(1, oFile.Name, sName, vbTextCompare) = 1 Then ' Names beginning with sName
' Check the extension to match
If LCase(objFSO.GetExtensionName(oFile)) = LCase(sFileType) Then
If objDict.Exists(oFile.Name) Then
' Append Path to existing entry
objDict.Item(oFile.Name) = objDict.Item(oFile.Name) & DIV & oFile.Path
Else
' Add Key and current path
objDict.Add oFile.Name, oFile.Path
End If
End If
End If
Next
' Recurse into each sub folder
For Each oFDR In objFDR.SubFolders
LookForFilesAlike sName, oFDR
Next
End Sub
Private Function CopyFiles() As String
Dim i As Long, oKeys As Variant, oItem As Variant, iRepeat As Integer, sName As String, sOut As String
sOut = ""
' Process the items for each key in Dictionary
Set oKeys = objDict.Keys ' <- Add "Set " before oKeys
For i = 0 To objDict.Count
For Each oItem In Split(objDict.Item(oKeys(i)), DIV)
' Determine the filename in destination path
If objFSO.FileExists(sDestinationPath & objFSO.GetFileName(oItem)) Then
' Same file name alreay found, try append " (i)"
iRepeat = 0
Do
iRepeat = iRepeat + 1
sName = objFSO.GetBaseName(oItem) & " (" & iRepeat & ")" & objFSO.GetExtensionName(oItem)
Loop While objFSO.FileExists(sDestinationPath & sName)
sName = sDestinationPath & sName
Else
' First file to be copied to destination folder
sName = sDestinationPath
End If
' Copy the source file to destination file
If Len(sOut) = 0 Then
sOut = oItem & DIV & sName
Else
sOut = sOut & vbLf & oItem & DIV & sName
End If
objFSO.CopyFile oItem, sName
Next
Next
CopyFiles = sOut
End Function
选项显式
'具有路径的源文件夹和目标文件夹。
Private Const sSourcePath=“C:\Users\nhatc\u 000\Desktop\01010101”
Private Const sdestinitionpath=“C:\Users\nhatc\u 000\Desktop\020202”
Private Const sFileType=“jpg”'尝试使用其他文件类型,如“.pdf”。
Private Const DIV=“|””不是合法文件名的字符
私有objFSO作为对象,objDict作为对象
子副本
朦胧如长,缠绵如弦
设置objFSO=CreateObject(“Scripting.FileSystemObject”)
如果不存在objFSO.FolderExists(sSourcePath),则
MsgBox“未找到源文件夹!”&vbCrLf&sSourcePath,vbCritical+vbOKOnly
好了,我做完了
如果结束
如果不存在objFSO.FolderExists(sDestinationPath),则
MsgBox“未找到目标文件夹!”&vbCrLf&sdestentiationpath,vbCritical+vbOKOnly
好了,我做完了
如果结束
'在同时找到源文件夹和目标文件夹时继续
设置objDict=CreateObject(“Scripting.Dictionary”)
lRow=2
直到IsEmpty(单元格(lRow,“A”)’在lRow中A列的第一个空单元格上停止
'获取要查找的主文件名
sName=单元格(lRow,“A”)。值
'查找要添加到词典的文件(子文件夹中的精确和相似文件)
lookforfilesamplesname,objFSO.GetFolder(sSourcePath)
'复制文件
如果objDict.Count=0,则
单元格(lRow,“B”).Value=“未找到任何文件。”
其他的
单元格(lRow,“B”).Value=objDict.Count和“找到的文件名”&vbLf和CopyFiles
如果结束
'清除字典中的下一个名称
objDict.RemoveAll
'增量行计数器
lRow=lRow+1
环
设置objDict=Nothing
我完成了:
设置objFSO=Nothing
端接头
私有子lookforfileslike(ByVal sName作为字符串,ByVal objFDR作为对象)
作为对象的文件的尺寸,作为对象的oFDR
'如果名称匹配,则将当前文件夹的文件添加到字典
对于objFDR.文件中的每个文件
如果InStr(1,oFile.Name,sName,vbTextCompare)=1,则“名称”以sName开头
'检查分机