from the below mentioned VBA code i am able to move files from Source to destination, however after moving the files i need to change the folder name by date everyday, is there anyway we can move the files directly to the updated date folder, the pattern of the folder name/folder date is

01102022
02102022
03102022

the code i have is

Option Explicit

Sub MoveFilesTEST()

    Const sFolderPath As String = "E:\Asianet2"
    Const dFolderPath As String = "E:\Asianet3"
    Const FilePattern As String = "*.*"
    
    MoveFiles sFolderPath, dFolderPath, FilePattern

End Sub

Sub MoveFiles( _
        ByVal SourceFolderPath As String, _
        ByVal DestinationFolderPath As String, _
        Optional ByVal FilePattern As String = "*.*")
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(SourceFolderPath) Then
        MsgBox "The source folder path '" & SourceFolderPath _
            & "' doesn't exist.", vbCritical
        Exit Sub
    End If
    
    If Not fso.FolderExists(DestinationFolderPath) Then
        MsgBox "The destination folder path '" & DestinationFolderPath _
            & "' doesn't exist.", vbCritical
        Exit Sub
    End If
    
    Dim apSep As String: apSep = Application.PathSeparator
    
    Dim sPath As String: sPath = SourceFolderPath
    If Left(sPath, 1) <> apSep Then sPath = sPath & apSep
        
    Dim sFolder As Object: Set sFolder = fso.GetFolder(sPath)
    If sFolder.Files.Count = 0 Then
        Exit Sub
    End If
    
    Dim dPath As String: dPath = DestinationFolderPath
    If Left(dPath, 1) <> apSep Then dPath = dPath & apSep
        
    Dim dFolder As Object: Set dFolder = fso.GetFolder(dPath)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sFile As Object
    Dim dFilePath As String
    Dim ErrNum As Long
    Dim MovedCount As Long
    Dim NotMovedCount As Long
    
    For Each sFile In sFolder.Files
        dFilePath = dPath & sFile.Name
        If fso.FileExists(dFilePath) Then
            dict(sFile.Path) = Empty
            NotMovedCount = NotMovedCount   1
        Else
            On Error Resume Next
                fso.MoveFile sFile.Path, dFilePath
                ErrNum = Err.Number
                ' e.g. 'Run-time error '70': Permission denied' e.g.
                ' when the file is open in Excel
            On Error GoTo 0
            If ErrNum = 0 Then
                MovedCount = MovedCount   1
            Else
                dict(sFile.Path) = Empty
                NotMovedCount = NotMovedCount   1
            End If
        End If
    Next sFile
    
    Dim Msg As String
     
End Sub

screenshot

CodePudding user response：

Please, use the next code. It creates the folder (as ddmmyyyy) in "dFolderPath" and moves all files existing in "sFolderPath":

Sub moveAllFilesInDateFolder()
 Dim DateFold As String, fileName As String
 Const sFolderPath As String = "E:\Asianet2"
 Const dFolderPath As String = "E:\Asianet3"
 
 DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy")' create the folder if it does not exist
 If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
 
 fileName = Dir(sFolderPath & "\*.*")
 If fileName = "" Then MsgBox "No any file in " & sFolderPath & "...": Exit Sub
 
 Do While fileName <> ""
    Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
    fileName = Dir
 Loop
End Sub

Please, send some feedback after testing it...

You probably would need previously checking if there are no files in "dateFold", to avoid asking for overwriting in case of running the code twice (in the same day, by mistake)...