CODEWITHSUNDEEP
excelvba
Robert
Robert

Reputation: 11

Move all pdf files to a new folder

I'd like to copy all files with pdf as extension to a new folder (with name from a cell)

I've created below code:

Public Sub MyFileprojectTF()

    Dim startPath As String
    Dim myName As String
    Dim SourceFileName As String, DestinFileName As String
    Dim FSOFile As Object
    Dim FSOFolder As Object

    FolderName = "C:\Users\320105013\Desktop\DXR\"

    Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
    Set FSOFolder = FSOLibrary.getfolder(FolderName)
    Set FSOFile = FSOFolder.Files
    Set fso = CreateObject("Scripting.Filesystemobject")
     
    startPath = "C:\Users\320105013\Desktop\DXR Test files\"
    myName = ActiveSheet.Range("B3").Text        ' Change as required to cell holding the folder title
    
    If myName = vbNullString Then myName = "Testing"

    Dim folderPathWithName As String
    folderPathWithName = startPath & Application.PathSeparator & myName

    If Dir(folderPathWithName, vbDirectory) = vbNullString Then
        MkDir folderPathWithName
    Else
        MsgBox "Folder already exists"
        Exit Sub
    End If
    
    ActiveWorkbook.FollowHyperlink startPath & myName
    
    SourceFileName = "C:\Users\320105013\Desktop\DXR\" & (FSOFile)
    DestinFileName = startPath & myName & "\"
     
    For Each FSOFile In FSOFile
        If FSOFile Like "*.pdf" Then
            FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName
        End If
    Next
End Sub

I get the following error:

"Wrong number of arguments"

on FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName.

Upvotes: 1

Views: 179

Answers (3)

VBasic2008
VBasic2008

Reputation: 54807

Move Files to a Folder

The Code

Option Explicit

Public Sub MyFileprojectTF()
    
    Const sFolderPath As String = "C:\Users\320105013\Desktop\DXR\"
    Const dStartPath As String = "C:\Users\320105013\Desktop\DXR Test files\"
    Const ExtensionPattern As String = "*.pdf"
    Dim pSep As String: pSep = Application.PathSeparator
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim dFolderName As String
    Dim dFolderPath As String
    dFolderName = wb.Worksheets("Sheet1").Range("B3").Value
    If dFolderName = vbNullString Then
        dFolderName = "Testing"
    End If
    dFolderPath = dStartPath & pSep & dFolderName
    
    If Dir(dFolderPath, vbDirectory) = vbNullString Then
        If Dir(sFolderPath & pSep & ExtensionPattern) <> vbNullString Then
            MkDir dFolderPath
            With CreateObject("Scripting.FileSystemObject")
                .MoveFile Source:=sFolderPath & pSep & ExtensionPattern, _
                    Destination:=dFolderPath
                wb.FollowHyperlink dFolderPath
            End With
        Else
            MsgBox "No matching files found in folder '" & sFolderPath & "'."
        End If
    Else
        MsgBox "Folder '" & dFolderPath & "' already exists"
    End If
    
End Sub

Upvotes: 0

Robert
Robert

Reputation: 11

Okay I've changed it to below but get error message "object doesn't support..." on line FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName

Public Sub MyFileprojectTF()

Dim startPath As String
Dim myName As String
Dim SourceFileName As String, DestinFileName As String
Dim FSOFile As Object
Dim FSOFiles As Object
Dim FSOFolder As Object

FolderName = "C:\Users\320105013\Desktop\DXR\"

Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSOLibrary.getfolder(FolderName)
Set FSOFiles = FSOFolder.Files
Set fso = CreateObject("Scripting.Filesystemobject")
 
startPath = "C:\Users\320105013\Desktop\DXR Test files\"
myName = ActiveSheet.Range("B3").Text        ' Change as required to cell holding the folder title

If myName = vbNullString Then myName = "Testing"

Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName

If Dir(folderPathWithName, vbDirectory) = vbNullString Then
    MkDir folderPathWithName
Else
   MsgBox "Folder already exists"
   Exit Sub
End If

ActiveWorkbook.FollowHyperlink startPath & myName

SourceFileName = "C:\Users\320105013\Desktop\DXR\"
    DestinFileName = startPath & myName & "\"
     
    For Each FSOFile In FSOFiles
        If FSOFile Like "*.pdf" Then
        FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName
        End If
    Next
 End Sub

Upvotes: 0

braX
braX

Reputation: 11755

You are using FSOFile twice as 2 different variables... see the 3 comments I added.

Public Sub MyFileprojectTF()

Dim startPath As String
Dim myName As String
Dim SourceFileName As String, DestinFileName As String
Dim FSOFile As Object
Dim FSOFiles As Object ' ADD THIS
Dim FSOFolder As Object

FolderName = "C:\Users\320105013\Desktop\DXR\"

Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSOLibrary.getfolder(FolderName)
Set FSOFiles = FSOFolder.Files ' CHANGE THIS
Set fso = CreateObject("Scripting.Filesystemobject")
 
startPath = "C:\Users\320105013\Desktop\DXR Test files\"
myName = ActiveSheet.Range("B3").Text        ' Change as required to cell holding the folder title

If myName = vbNullString Then myName = "Testing"

Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName

If Dir(folderPathWithName, vbDirectory) = vbNullString Then
    MkDir folderPathWithName
Else
   MsgBox "Folder already exists"
   Exit Sub
End If

ActiveWorkbook.FollowHyperlink startPath & myName

SourceFileName = "C:\Users\320105013\Desktop\DXR\" & (FSOFile)
DestinFileName = startPath & myName & "\"
 
    For Each FSOFile In FSOFiles ' CHANGE THIS
        If FSOFile Like "*.pdf" Then
        FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName
    End If
    Next
 End Sub

Upvotes: 1

Related Questions