我之前有一个问题，我需要在单个文件夹中搜索该文件夹中的3个最新文件，然后将这3个文件复制到新文件夹中 - 这个问题得到了解答，可以在这里找到该主题：
Identify and Copy latest files in directory
我现在的下一个问题是：
1）我有一个包含20个子文件夹的主文件夹
2）每天早上7点左右，新的csv提取物被添加到每个子文件夹
2）我需要搜索每个子文件夹，找到添加到该子文件夹的最新（当前日期）文件
3）然后，我需要从各自的子文件夹中复制每个单独的文件，并将所有文件放在 ONE 文件夹中 - 没有机会文件名永远都是一样的
我需要将两个代码解决方案合并为一个：
解决方案1 （可在上面的链接中找到）：此文件将根据以下内容复制单个目录中的所有文件当前日期到单独的文件夹
Option Explicit
Dim FolderToCheck, FolderDestination, FileExt, mostRecent, noFiles, fso, fileList, file, filecounter, oShell, strHomeFolder
' Enumerate current user's home path - we will use that by default later if nothing specified in commandline
Set oShell = CreateObject("WScript.Shell")
strHomeFolder = oShell.ExpandEnvironmentStrings("%USERPROFILE%")
'Variables -----
folderToCheck = strHomeFolder & "\Desktop\Terminations" ' Folder Source to check for recent files to copy FROM
folderDestination = strHomeFolder & "\Desktop\Terminations\Sorted" ' Destination Folder where to copy files TO
fileExt = "csv" ' Extension we are searching for
mostRecent = 3 ' Most Recent number of files to copy
' --------------
PreProcessing() ' Retrieve Command Line Parameters
' Display what we are intending on doing
wscript.echo "Checking Source: " & FolderToCheck
wscript.echo "For Files of type: " & FileExt
wscript.echo "Copying most recent "& mostRecent &" file(s) to: " & FolderDestination & "."
noFiles = TRUE
Set fso = CreateObject("Scripting.FileSystemObject")
Set fileList = CreateObject("ADOR.Recordset")
fileList.Fields.append "name", 200, 255
fileList.Fields.Append "date", 7
fileList.Open
If fso.FolderExists(FolderToCheck) Then
For Each file In fso.GetFolder(FolderToCheck).files
If LCase(fso.GetExtensionName(file)) = LCase(FileExt) then
fileList.AddNew
fileList("name").Value = File.Path
fileList("date").Value = File.DateLastModified
fileList.Update
If noFiles Then noFiles = FALSE
End If
Next
If Not(noFiles) Then
wscript.echo fileList.recordCount & " File(s) found. Sorting and copying last " & mostRecent &"..."
fileList.Sort = "date DESC"
If Not(fileList.EOF) Then
fileList.MoveFirst
If fileList.recordCount < mostRecent Then
wscript.echo "WARNING: " & mostRecent &" file(s) specified but only " & fileList.recordcount & " file(s) match criteria. Adjusted to " & fileList.RecordCount & "."
mostRecent = fileList.recordcount
End If
fileCounter = 0
Do Until fileList.EOF Or fileCounter => mostRecent
If Not(fso.FolderExists(folderDestination)) Then
wscript.echo "Destination Folder did not exist. Creating..."
fso.createFolder folderDestination
End If
fso.copyfile fileList("name"), folderDestination & "\", True
wscript.echo fileList("date").value & vbTab & fileList("name")
fileList.moveNext
fileCounter = fileCounter + 1
Loop
Else
wscript.echo "An unexpected error has occured."
End If
Else
wscript.echo "No matching """ & FileExt &""" files were found in """ & foldertocheck & """ to copy."
End If
Else
wscript.echo "Error: Source folder does not exist """ & foldertocheck & """."
End If
fileList.Close
Function PreProcessing
Dim source, destination, ext, recent
' Initialize some variables
Set source = Nothing
Set destination = Nothing
Set ext = Nothing
Set recent = Nothing
source = wscript.arguments.Named.Item("source")
destination = wscript.arguments.Named.Item("destination")
ext = wscript.arguments.Named.Item("ext")
recent = wscript.arguments.Named.Item("recent")
If source <> "" Then FolderToCheck = source
If destination <> "" Then FolderDestination = destination
If ext <> "" Then FileExt = ext
If recent <> "" Then mostRecent = int(recent)
End Function
解决方案2 ：此解决方案将以递归方式文件从基于文件类型的子目录中的子文件夹复制到单独的文件夹中
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objStartFolder : objStartFolder = "C:\Users\Desktop\3rd Party"
Dim objDestFolder : objDestFolder = "C:\Users\Desktop\3rd Party\Work Folder"
Dim objFolder : Set objFolder = objFSO.GetFolder(objStartFolder)
Dim Subfolder
Dim colFiles
Dim objFile
Set objDestFolder = objFSO.GetFolder(objDestFolder)
CopySubFolders objFSO.GetFolder(objStartFolder)
Sub CopySubFolders(Folder)
For Each Subfolder in Folder.SubFolders
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
For Each objFile in colFiles
If instr(objFile.path,"3rd Party") AND lcase(Right(objFile.Name,4))=".csv" Then
'Wscript.echo "Copying File:" & objFile.path
ObjFSO.CopyFile objFile.Path, "C:\Users\Desktop\3rd Party\Work Folder\"
End If
If instr(objFile.path,"3rd Party") AND lcase(Right(objFile.Name,4))=".xlsx" Then
'Wscript.echo "Copying File:" & objFile.path
ObjFSO.CopyFile objFile.Path, "C:\Users\Desktop\3rd Party\Work Folder\"
End If
If instr(objFile.path,"3rd Party") AND lcase(Right(objFile.Name,4))=".xls" Then
'Wscript.echo "Copying File:" & objFile.path
ObjFSO.CopyFile objFile.Path, "C:\Users\Desktop\3rd Party\Work Folder\"
End If
Next
CopySubFolders Subfolder
Next
End Sub
所以我需要的是搜索子文件夹并根据两件事复制每个文件夹中的文件：最后修改日期是当前日期和文件类型是csv，xls或xlsx。
我还发现了一个应该跳过某些文件夹的代码片段，但是如果我把这段代码放在For Each循环中，那么它就会爆炸 - ＆＃34;预期陈述＆＃34;。
以下是代码：
If Subfolder.Name <> "Exchange" and Subfolder.Name <> "HR_Daily_terminations" and Subfolder.Name <> "pay" and Subfolder.Name <> "Terminations" and Subfolder.Name <> "Work Folder" Then
在Fore Each循环结束之前，我放了End If语句。
所以它看起来像这样：
For Each Subfolder in Folder.SubFolders
If Subfolder.Name <> "Exchange" and Subfolder.Name <> "HR_Daily_terminations" and Subfolder.Name <> "pay" and Subfolder.Name <> "Terminations" and Subfolder.Name <> "Work Folder" Then
Set objFolder = objFSO.GetFolder(Subfolder.Path)
Set colFiles = objFolder.Files
For Each objFile in colFiles
If instr(objFile.path,"3rd Party") AND lcase(Right(objFile.Name,4))=".csv" Then
'Wscript.echo "Copying File:" & objFile.path
ObjFSO.CopyFile objFile.Path, "C:\Users\Desktop\3rd Party\Work Folder\"
End If
If instr(objFile.path,"3rd Party") AND lcase(Right(objFile.Name,4))=".xlsx" Then
'Wscript.echo "Copying File:" & objFile.path
ObjFSO.CopyFile objFile.Path, "C:\Users\Desktop\3rd Party\Work Folder\"
End If
If instr(objFile.path,"3rd Party") AND lcase(Right(objFile.Name,4))=".xls" Then
'Wscript.echo "Copying File:" & objFile.path
ObjFSO.CopyFile objFile.Path, "C:\Users\Desktop\3rd Party\Work Folder\"
End If
End If
Next
CopySubFolders Subfolder
Next
答案 0 :(得分：0)
请注意我找到了上述问题的解决方案，代码如下：
' Require variables to be defined
Option Explicit
' Global variables
Dim strBaseFolder
Dim strDestFolder
Dim objFSO
Dim objFolder
Dim objFile
' Define folders to work with
strBaseFolder = "C:\Users\Desktop\3rd Party"
strDestFolder = "C:\Users\Desktop\3rd Party\Work Folder"
' Create filesystem object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Exit if base folder does not exist
If Not objFSO.FolderExists(strBaseFolder) Then
Wscript.Echo "Missing base folder : """ & strBaseFolder & """"
Wscript.Quit
End If
' Exit if dest folder does not exist
If Not objFSO.FolderExists(strDestFolder) Then
Wscript.Echo "Missing dest folder : """ & strDestFolder & """"
Wscript.Quit
End If
' Look at each subfolder of base folder
For Each objFolder In objFSO.GetFolder(strBaseFolder).SubFolders
' Continue if we want this folder
If IncludeFolder(objFolder) Then
' Check each file in this folder
For Each objFile In objFolder.Files
' Continue if we want this file
If IncludeFile(objFile) Then
' Copy the file
'Wscript.Echo "Copying File :""" & objFile.Path & """"
objFile.Copy strDestFolder & "\" & objFile.Name
End If
Next
End If
Next
' Logic to determine if we process a folder
Function IncludeFolder(objFolder)
' Exclude certain folder names
Select Case LCase(objFolder.Name)
Case "exchange", "hr_daily_terminations", "pay", "terminations", "work folder"
IncludeFolder = False
Case Else
IncludeFolder = True
End Select
End Function
' Logic to determine if we process a file
Function IncludeFile(objFile)
IncludeFile = False
Select Case LCase(objFSO.GetExtensionName(objFile.Path))
' Include only these extensions
Case "csv", "xls", "xlsx"
' Include only files dated today
If DateDiff("d", objFile.DateLastModified, Now) = 0 Then
IncludeFile = True
End If
End Select
End Function