폴더를 순환하며 파일을 루트로 옮기기

 

폴더를 선택하면

폴더 안의 하위 폴더도 모두 순환하며

최초 선택한 폴더로 파일을 모두 옮긴 후 폴더는 삭제하는 코드

 

파일명이 중복될 경우 난수를 생성해준다.

뤼튼 만세 ㅋㅋㅋ

 

Sub MoveFilesInSelectedFolder()
    Dim sourceFolder As String
    Dim destFolder As String
    Dim fso As Object
    Dim sourceFolderObj As Object
    Dim destFolderObj As Object
    Dim subFolder As Object
    Dim file As Object
    Dim fileName As String, newFileName As String
    Dim fileExists As Boolean
    Dim rndNumber As Integer

    ' 대화창을 열어 사용자로부터 폴더 선택
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "폴더 선택"
        .AllowMultiSelect = False
        If .Show = -1 Then
            sourceFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    destFolder = sourceFolder
    
    ' 파일 시스템 개체 생성
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sourceFolderObj = fso.GetFolder(sourceFolder)
    Set destFolderObj = fso.GetFolder(destFolder)
    
    ' 모든 하위 폴더와 파일에 대해 순환
    For Each subFolder In sourceFolderObj.SubFolders
        ' 하위 폴더 내의 파일에 대해 순환
        For Each file In subFolder.Files
            fileName = file.Name
            fileExists = fso.fileExists(destFolder & "\" & fileName)
            If fileExists Then
                ' 파일명 중복 시 난수 추가
                rndNumber = Int((9999 - 1000 + 1) * Rnd + 1000)
                newFileName = fso.GetBaseName(fileName) & "_" & rndNumber & "." & fso.GetExtensionName(fileName)
            Else
                newFileName = fileName
            End If
            
            ' 파일 이동
            file.Move destFolder & "\" & newFileName
        Next file
        
        ' 하위 폴더 내의 하위 폴더에 대해 재귀적으로 호출
        MoveFilesInSubFolders subFolder.Path, destFolder
    Next subFolder
    
    '빈 폴더 삭제
    DeleteEmptyFolders sourceFolder
    
End Sub

Sub MoveFilesInSubFolders(ByVal folderPath As String, ByVal destFolder As String)
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim subFolder As Object
    Dim fileName As String, newFileName As String
    Dim fileExists As Boolean
    Dim rndNumber As Integer
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    For Each file In folder.Files
        fileName = file.Name
        fileExists = fso.fileExists(destFolder & "\" & fileName)
        If fileExists Then
            ' 파일명 중복 시 난수 추가
            rndNumber = Int((9999 - 1000 + 1) * Rnd + 1000)
            newFileName = fso.GetBaseName(fileName) & "_" & rndNumber & "." & fso.GetExtensionName(fileName)
        Else
            newFileName = fileName
        End If
        
        ' 파일 이동
        file.Move destFolder & "\" & newFileName
    Next file
    
    For Each subFolder In folder.SubFolders
        ' 재귀적으로 하위 폴더 내의 파일에 대해 호출
        MoveFilesInSubFolders subFolder.Path, destFolder
    Next subFolder
       
End Sub

Sub DeleteEmptyFolders(ByVal folderPath As String)
    Dim fso As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim isEmpty As Boolean
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 현재 폴더의 하위 폴더에 대해 재귀적으로 호출
    For Each subFolder In folder.SubFolders
        DeleteEmptyFolders subFolder.Path
    Next subFolder
    
    ' 현재 폴더가 빈 폴더인지 확인
    isEmpty = (folder.Files.Count = 0) And (folder.SubFolders.Count = 0)
    
    ' 빈 폴더일 경우 삭제
    If isEmpty Then
        fso.DeleteFolder folder.Path
    End If
End Sub

사진 날짜별 분류.xlsm

0.02MB