針對資料夾內所有子資料夾所有照片及影片檔案都移到最上層資料夾用VBA寫一個針對相片及影片的建立日、修改日、存取日判斷，以這三個日期中最小的日期依年月資料夾分類，如果該資料夾不存在就新建，當檔案名稱如果重複時就自動在檔案名稱依序給予 _+流水號
分類結果4436個影片及照片自動移到最上層資料夾，只花不到1分鐘
 |
| 分類結果 |
 |
| 同一時間處理完畢 |
Sub OrganizePhotosAndVideosByDate()
Dim topFolderPath As String
Dim fso As Object
Dim topFolder As Object
Dim subFolder As Object
Dim file As Object
Dim earliestDate As Date
Dim yearMonth As String
Dim targetFolder As String
Dim fileExtensions As Variant
Dim i As Integer
Dim fileName As String
Dim newFileName As String
Dim counter As Integer
' 設置要處理的頂層資料夾路徑
topFolderPath = "C:\Your\Path\To\PhotosAndVideos" ' 替換為實際的路徑
' 要處理的文件副檔名
fileExtensions = Array("jpg", "jpeg", "png", "gif", "bmp", "mp4", "avi", "mov", "wmv", "mkv")
' 創建 FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
Set topFolder = fso.GetFolder(topFolderPath)
' 遍歷頂層資料夾及其所有子資料夾中的每個檔
Call ProcessFolder(topFolder, fso, topFolderPath, fileExtensions)
MsgBox "Files have been organized by date.", vbInformation
End Sub
Sub ProcessFolder(folder As Object, fso As Object, topFolderPath As String, fileExtensions As Variant)
Dim file As Object
Dim subFolder As Object
Dim earliestDate As Date
Dim yearMonth As String
Dim targetFolder As String
Dim fileName As String
Dim newFileName As String
Dim counter As Integer
' 遍歷資料夾中的每個檔
For Each file In folder.Files
' 檢查檔副檔名是否在目標副檔名清單中
If IsInArray(LCase(fso.GetExtensionName(file.Path)), fileExtensions) Then
' 獲取檔的創建日期、修改日期和訪問日期
earliestDate = GetEarliestDate(file.DateCreated, file.DateLastModified, file.DateLastAccessed)
' 格式化為 "YYYY-MM" 格式
yearMonth = Format(earliestDate, "YYYY-MM")
' 設置目的檔案夾路徑
targetFolder = topFolderPath & "\" & yearMonth
' 如果目的檔案夾不存在，則創建新資料夾
If Not fso.FolderExists(targetFolder) Then
fso.CreateFolder(targetFolder)
End If
' 設置初始檔案名
fileName = fso.GetBaseName(file.Name) & "." & fso.GetExtensionName(file.Name)
newFileName = fileName
counter = 1
' 如果目的檔案夾中已存在同名檔，則添加序號
Do While fso.FileExists(targetFolder & "\" & newFileName)
newFileName = fso.GetBaseName(file.Name) & "_" & counter & "." & fso.GetExtensionName(file.Name)
counter = counter + 1
Loop
' 移動文件到目的檔案夾
file.Move targetFolder & "\" & newFileName
End If
Next file
' 遞迴處理子資料夾
For Each subFolder In folder.SubFolders
Call ProcessFolder(subFolder, fso, topFolderPath, fileExtensions)
Next subFolder
End Sub
' 函數：檢查陣列中是否包含指定值
Function IsInArray(value As Variant, arr As Variant) As Boolean
Dim element As Variant
IsInArray = False
For Each element In arr
If element = value Then
IsInArray = True
Exit Function
End If
Next element
End Function
' 函數：獲取最早的日期
Function GetEarliestDate(date1 As Date, date2 As Date, date3 As Date) As Date
GetEarliestDate = Application.WorksheetFunction.Min(date1, date2, date3)
End Function
代碼說明：
頂層資料夾路徑和檔副檔名：topFolderPath 變數指定要處理的頂層資料夾路徑，請將其替換為實際的路徑。fileExtensions 陣列包含要處理的檔案類型副檔名。
遍歷資料夾和文件：ProcessFolder 副程式遞迴遍歷指定資料夾及其所有子資料夾中的每個檔，並調用 IsInArray 函數檢查檔副檔名是否在目標副檔名清單中。
日期比較和分類：對於每個檔，獲取其創建日期、修改日期和訪問日期，並計算最早的日期。然後按 YYYY-MM 格式分類到對應的資料夾中。如果目的檔案夾不存在，則創建新的資料夾。
處理檔案名衝突：如果目的檔案夾中已存在同名檔，則添加序號以避免檔案名衝突。
輔助函數：IsInArray 函數用於檢查檔副檔名是否在目標副檔名清單中，GetEarliestDate 函數用於獲取三個日期中的最早日期。
運行此宏後，指定頂層資料夾及其所有子資料夾中的所有照片和視頻檔將移到最上層資料夾，並按最早日期的年月分類到對應的資料夾中。如果檔案名重複，將自動在檔案名後添加序號。
沒有留言:
張貼留言