Search code examples
vbapowerpointfso

VBA - save & rename powerpoint and move old one to a new folder. using fso.movefile, but the files aren't moving


Trying to write a code where I loop through a subfolder, update and rename a powerpoint with a new name, and then move the old one to an Archive folder. The first 2 parts work, but the last part does not. I end up with both the old file and the new one in the original path. What am I doing wrong?

If needed, the "update" is basically copying one slide from a different master deck and copying it into the powerpoint.

Sub CopyDepositModelingWSCards()

    Dim AreaReport As Presentation, oSld As Slide
    Dim MasterPPT As Presentation
    Set MasterPPT = ActivePresentation
    Dim MyFile As String
    Dim fso As New FileSystemObject
    
    filepath = [path]
   
    Set f = CreateObject("Scripting.Filesystemobject").GetFolder(filepath)
     
    i = 44 'used master ppt slide index
    
        For Each subFolder In f.subfolders
            Debug.Print subFolder.Name
            
                 'loop files in subfolders
                If subFolder Like "*Completed*" Then
                    'Do nothing
                ElseIf subFolder Like "*Archive*" Then
                    'Do nothing
                Else
                    
                    For Each f In subFolder.Files
                        
                        If LCase(f.Name) Like "*.ppt*" Then
                            Debug.Print , f.Path
                        
                        Set AreaReport = Presentations.Open(f, WithWindow:=msoTrue)
                        
                        'get file name without file extension
                        currentFileName = Left(Application.ActivePresentation.Name, Len(Application.ActivePresentation.Name) - 5)
                        
                        'set new file name with the current date
                        newFileName = ActivePresentation.Path & "\" & Left(currentFileName, Len(currentFileName) - 8) & Format(Now(), "YYYYMMDD")
                        
                            With Application.ActivePresentation
                                
                                SourceFileName = ActivePresentation.FullName
                                DestinFolder = ActivePresentation.Path & "\Archive\"
                                
                                'Debug.Print (SourceFileName)
                                'Debug.Print (DestinFolder)
                                       
                                .SaveAs newFileName
                            
                                MasterPPT.Slides(i).Copy
                                AreaReport.Slides.Paste (1)
                                AreaReport.Slides.Item(1).Design = _
                                    MasterPPT.Slides.Item(2).Design
                                    
                                AreaReport.Slides(2).Delete
                                
                                .SaveAs newFileName
                                
                                On Error Resume Next
                                fso.MoveFile Source:=SourceFileName, Destination:=DestinFolder
                                
                                'PowerPoint.Application.Presentations(SourceFileName).Close
                                fso.MoveFile Source:=SourceFileName, Destination:=DestinFolder
                                
                            End With
                            AreaReport.Close
                        End If
                    Next f
                End If
            i = i + 1
        Next subFolder
    
    MsgBox ("Complete")
End Sub

Solution

  • You need to pass the full path - including the file name - to Destination, so this should work:

    fso.MoveFile source:=f.path, Destination:=f.parentfolder & "\Archive\" & f.Name
    

    Also don't forget fso has handy methods like GetBaseName and GetExtensionName which can replace some of that Left/Right/Mid code.