Macro to move csv files within-subfolder to folder "Old Templates"

[howard]

I have csv files within each sub-folder within "\\mxwk\Sales"

I have adapted code to move the CSV files where the dates last modified is prior to the date in F1 (date format dd/mm/yyyy) within each sub-folder eg \\mxwk\Sales\BR1 to "Old Templates" within each of the sub-folders. I get a run time error "permission denied" and this section of the code is highlighted

 For Each FileItem In SubFolder.files

I can manullly move the files, but not using VBA

Kindly check & amend my code

 Sub MoveCSVFilesToOldDownloads()
    On Error GoTo ErrorHandler

    Dim SourceFolder As String
    Dim DestinationFolder As String
    Dim FileExtension As String
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim FSO As Object
    Dim MacroSheet As Worksheet
    Dim ReferenceDate As Date

    ' Set the source folder path
    SourceFolder = "\\mxwk\Sales"

    ' Create a FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")

    ' Check if the source folder exists
    If Not FSO.FolderExists(SourceFolder) Then
        MsgBox "Source folder does not exist!"
        Exit Sub
    End If

    ' Set the file extension to filter for CSV files
    FileExtension = ".csv"

    ' Set the reference date from cell F1 in the "Macro" sheet
    Set MacroSheet = ThisWorkbook.Sheets("Macro")
    ReferenceDate = MacroSheet.Range("F1").Value

    ' Loop through sub-folders in the source folder
    For Each SubFolder In FSO.GetFolder(SourceFolder).SubFolders
        ' Construct the destination folder path
        DestinationFolder = SubFolder.Path & "\Old Templates"

       

            On Error Resume Next ' Ignore errors during folder creation
            FSO.CreateFolder DestinationFolder
            On Error GoTo 0 ' Disable ignoring errors
      

     

        ' Loop through files in the sub-folder
        For Each FileItem In SubFolder.files
            ' Check if the file has the CSV extension (case-insensitive)
            If StrComp(FSO.GetExtensionName(FileItem.Path), FileExtension, vbTextCompare) = 0 Then
                ' Check if the file's last modified date is earlier than the reference date
                If FileItem.DateLastModified < ReferenceDate Then
                    ' Call the MoveCSVFileIfNeeded function to handle the file movement
                    MoveCSVFileIfNeeded FileItem.Path, DestinationFolder
                End If
            End If
        Next FileItem
    Next SubFolder

    ' Release the FileSystemObject
    Set FSO = Nothing

    MsgBox "CSV files modified prior to the specified date have been moved to the Old Template folders."
    Exit Sub

ErrorHandler:
    MsgBox "Error: " & Err.Description
End Sub


Sub MoveCSVFileIfNeeded(filePath As String, DestinationFolder As String)
    Dim FSO As Object

    ' Create a FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")

    ' Check if the script has write access to move the file
    If Not FolderHasWritePermissions(DestinationFolder) Then
        MsgBox "Insufficient permissions to move the file: " & filePath
        Exit Sub
    End If

    ' Move the file to the destination folder
    On Error Resume Next ' Ignore errors during file movement
    FSO.MoveFile filePath, DestinationFolder & "\" & FSO.GetFileName(filePath)
    If Err.Number <> 0 Then
        MsgBox "Error moving file: " & filePath & vbCrLf & "Error: " & Err.Description
        Err.Clear
    End If
    On Error GoTo 0 ' Disable ignoring errors
End Sub




Sub RecursiveFileSearchAndMove(ByVal FolderPath As String, ByVal searchText As String, ByRef ws As Worksheet, ByRef lastRow As Long)
    Dim file As Object
    Dim files As Object
    Dim lastModified As Date
    Dim FSO As Object
    Dim DestinationFolder As String

    ' Create file system objects
    Set files = CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath).files
    Set FSO = CreateObject("Scripting.FileSystemObject")

    ' Check files in the current folder
    For Each file In files
        If UCase(file.Name) Like UCase(searchText) And Left(file.Name, 1) <> "~" Then
            lastModified = file.DateLastModified
            ' Check if the file was modified within the last 60 days
            If DateDiff("d", lastModified, Date) <= 60 Then
                ' Extract file name and copy to the Import Templates sheet
                ws.Cells(lastRow, "A").Value = file.Name
                lastRow = lastRow + 1

                ' Check if the file has the CSV extension (case-insensitive)
                If StrComp(FSO.GetExtensionName(file.Path), ".csv", vbTextCompare) = 0 Then
                    ' Construct the destination folder path
                    DestinationFolder = "\\mxwk\Sales"\Old Templates"

                    ' Check if the destination folder exists, if not, create it
                    If Not FSO.FolderExists(DestinationFolder) Then
                        On Error Resume Next ' Ignore errors during folder creation
                        FSO.CreateFolder DestinationFolder
                        On Error GoTo 0 ' Disable ignoring errors
                    End If

                    ' Check if the script has write access to move the file
                    If FolderHasWritePermissions(DestinationFolder) Then
                        ' Move the file to the destination folder
                        On Error Resume Next ' Ignore errors during file movement
                        FSO.MoveFile file.Path, DestinationFolder & "\" & FSO.GetFileName(file.Path)
                        If Err.Number <> 0 Then
                            MsgBox "Error moving file: " & file.Path & vbCrLf & "Error: " & Err.Description
                            Err.Clear
                        End If
                        On Error GoTo 0 ' Disable ignoring errors
                    Else
                        MsgBox "Insufficient permissions to move the file: " & file.Path
                    End If
                End If

                ' Open the file without displaying messages
                Application.DisplayAlerts = False ' Suppress display alerts
                Application.ScreenUpdating = False ' Turn off screen updating
                Application.Workbooks.Open file.Path, UpdateLinks:=True
                Application.DisplayAlerts = True ' Enable display alerts
                Application.ScreenUpdating = True ' Turn on screen updating
            End If
        End If
    Next file
End Sub

 

[JEC]

Very long code for a task like this. Maybe you miss some backslashes. Maybe even more than only these two.

SourceFolder = "\\mxwk\Sales\"

DestinationFolder = SubFolder.Path & "\Old Templates\"

 

[howard]

Thanks for the fedback. Will Try This