[英]How to loop through sub folders of folder A to get file name in each subfolder and copy other file with same name from folder B using VBA
There is folder A which contains multiple subfolders like A1,A2, A3 etc which every subfolder has mostly one sometimes 2 word files with the name(eg file_a1) in it.文件夹 A 包含多个子文件夹,如 A1、A2、A3 等,每个子文件夹大多有一个有时是 2 个单词的文件,其中包含名称(例如 file_a1)。 Then, there is other folder B (not a subfolder of A) which contains multiple word files with standard similar (file_a1_XZ) names.然后,还有另一个文件夹 B(不是 A 的子文件夹),其中包含多个具有标准相似 (file_a1_XZ) 名称的单词文件。 I want to loop in subfolders of A and copy word files from B to respective sub folder eg A1我想在 A 的子文件夹中循环并将 word 文件从 B 复制到相应的子文件夹,例如 A1
File Structure:文件结构:
Parent Folder
|
|
----Parent B
|
|
--- B
|
-file_a1_XZ
-file_a2_XZ
----Parent A
|
|
--- A
|
|
-- A1
|
-file_a1
-- A2
|
-file_a2
Dir
使用Dir
将文件移动到特定文件夹B
to subfolders of A
ie the filenames contain the names of the subfolders.将文件从B
移动到A
的子文件夹,即文件名包含子文件夹的名称。Option Explicit
Sub MoveFiles()
Const sFolderPath As String = "C:\Test\T2022\71752347\B\"
Const dFolderPath As String = "C:\Test\T2022\71752347\A\"
Const sExtensionPattern As String = ".doc*"
Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Do Until Len(dFolderName) = 0
If dFolderName <> "." And dFolderName <> ".." Then
dict(dFolderName) = Empty
End If
dFolderName = Dir
Loop
Dim Key As Variant
Dim sFileName As String
Dim fCount As Long
For Each Key In dict.Keys
sFileName = Dir(sFolderPath & "*" & Key & "*" & sExtensionPattern)
Do Until Len(sFileName) = 0
fCount = fCount + 1
FileCopy sFolderPath & sFileName, _
dFolderPath & Key & "\" & sFileName
Kill sFolderPath & sFileName
sFileName = Dir
Loop
Next
MsgBox "Files moved: " & fCount, vbInformation
End Sub
Sub MoveFiles()
Const sFolderPath As String = "C:\Test\T2022\71752347\B\"
Const dFolderPath As String = "C:\Test\T2022\71752347\A\"
Const sExtensionPattern As String = ".doc*"
Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Do Until Len(dFolderName) = 0
If dFolderName <> "." And dFolderName <> ".." Then
dict(dFolderName) = Empty
End If
dFolderName = Dir
Loop
Dim sFilePaths() As String
Dim sFilePath As String
Dim dFilePath As String
Dim Key As Variant
Dim f As Long
Dim fCount As Long
For Each Key In dict.Keys
sFilePaths = ArrFilePaths(sFolderPath, _
"*" & Key & "*" & sExtensionPattern)
For f = 0 To UBound(sFilePaths)
fCount = fCount + 1
sFilePath = sFilePaths(f)
dFilePath = dFolderPath & Key & "\" & Right(sFilePath, _
Len(sFilePath) - InStrRev(sFilePath, "\"))
FileCopy sFilePath, dFilePath
Kill sFilePath
Next f
Next Key
MsgBox "Files moved: " & fCount, vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the file paths of the files in a folder
' in a zero-based string array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "*.*", _
Optional ByVal DirSwitches As String = "/s/b/a-d") _
As String()
Const ProcName As String = "ArrFilePaths"
On Error GoTo ClearError
' Ensuring that a string array is passed if an error occurs.
ArrFilePaths = Split("") ' LB = 0 , UB = -1
Dim pSep As String: pSep = Application.PathSeparator
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
ExecString = "%comspec% /c Dir """ _
& FolderPath & FilePattern & """ " & DirSwitches
Dim Arr() As String: Arr = Split(CreateObject("WScript.Shell") _
.Exec(ExecString).StdOut.ReadAll, vbCrLf)
If UBound(Arr) > 0 Then
ReDim Preserve Arr(0 To UBound(Arr) - 1)
End If
ArrFilePaths = Arr
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.