Блог

Я хотел бы скопировать все файлы с расширением pdf в новую папку (с именем из ячейки)

Я создал приведенный ниже код:

 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:Users320105013DesktopDXR"

    Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
    Set FSOFolder = FSOLibrary.getfolder(FolderName)
    Set FSOFile = FSOFolder.Files
    Set fso = CreateObject("Scripting.Filesystemobject")
     
    startPath = "C:Users320105013DesktopDXR 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 amp; Application.PathSeparator amp; myName

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

Я получаю следующую ошибку:

«Неправильное количество аргументов»

вкл FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName .

Вы используете FSOFile дважды как 2 разные переменные… посмотрите 3 комментария, которые я добавил.

 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:Users320105013DesktopDXR"

Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSOLibrary.getfolder(FolderName)
Set FSOFiles = FSOFolder.Files ' CHANGE THIS
Set fso = CreateObject("Scripting.Filesystemobject")
 
startPath = "C:Users320105013DesktopDXR 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 amp; Application.PathSeparator amp; myName

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

ActiveWorkbook.FollowHyperlink startPath amp; myName

SourceFileName = "C:Users320105013DesktopDXR" amp; (FSOFile)
DestinFileName = startPath amp; myName amp; ""
 
    For Each FSOFile In FSOFiles ' CHANGE THIS
        If FSOFile Like "*.pdf" Then
        FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName
    End If
    Next
 End Sub
 

Хорошо, я изменил его на приведенное ниже, но получаю сообщение об ошибке «объект не поддерживает …» в строке FSOFile.MoveFile Источник:=имя_файла источника, Назначение:=имя_файла назначения

 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:Users320105013DesktopDXR"

Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSOLibrary.getfolder(FolderName)
Set FSOFiles = FSOFolder.Files
Set fso = CreateObject("Scripting.Filesystemobject")
 
startPath = "C:Users320105013DesktopDXR 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 amp; Application.PathSeparator amp; myName

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

ActiveWorkbook.FollowHyperlink startPath amp; myName

SourceFileName = "C:Users320105013DesktopDXR"
    DestinFileName = startPath amp; myName amp; ""
     
    For Each FSOFile In FSOFiles
        If FSOFile Like "*.pdf" Then
        FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName
        End If
    Next
 End Sub
 

Перемещение файлов в папку

• Использование этого MoveFile метода — самый простой способ.

Кодекс

 Option Explicit

Public Sub MyFileprojectTF()
    
    Const sFolderPath As String = "C:Users320105013DesktopDXR"
    Const dStartPath As String = "C:Users320105013DesktopDXR 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 amp; pSep amp; dFolderName
    
    If Dir(dFolderPath, vbDirectory) = vbNullString Then
        If Dir(sFolderPath amp; pSep amp; ExtensionPattern) <> vbNullString Then
            MkDir dFolderPath
            With CreateObject("Scripting.FileSystemObject")
                .MoveFile Source:=sFolderPath amp; pSep amp; ExtensionPattern, _
                    Destination:=dFolderPath
                wb.FollowHyperlink dFolderPath
            End With
        Else
            MsgBox "No matching files found in folder '" amp; sFolderPath amp; "'."
        End If
    Else
        MsgBox "Folder '" amp; dFolderPath amp; "' already exists"
    End If
    
End Sub