获取文件，复制该文件，然后创建一个文件夹，然后将该文件粘贴到创建的文件夹中

Question

因此，基本上，我需要将pdf文件从一个文件夹传输到另一个文件夹。但是源文件夹包含成千上万个pdf，我需要将约500多个pdf转移到我也应该创建的另一个文件夹中。因此，这意味着我先从源复制“ apple”，然后在目标文件夹中，我将创建一个名为“ apple”的文件夹，然后将复制的“ apple”文件粘贴到创建的“ apple”文件夹中。

Sub transferpdf()
Application.ScreenUpdating = False
Sheets("Stress Log").Activate
r = 3
'Declare Variables
'Do While Cells(r, 3) <> ""
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
Dim foldname As String
Call create_folder

'Name of new folder
'foldname = Cells(r, 1)
'File name to copy
sFile = Cells(r, 3) & "_R" & Cells(r, 4) & ".pdf"

'Source file path
sSFolder = "\\Fdnet.com\ca_projects\CA_LNGC\000_GENERAL\TRANSFER\TO CSA_From Stress  - PERMANENT\"

'Destination file path
sDFolder = "C:\Users\vid14865\Desktop\VLM - Sir Earl\3RC430BB VLM - Stress ISOs\" & foldname

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

'Checking If File Is Located in the Source Folder
If Not FSO.FileExists(sSFolder & sFile) Then
    MsgBox [sFile] & " Not Found", vbInformation, "Not Found"

'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & sFile) Then
    FSO.CopyFile (sSFolder & sFile), sDFolder, True
    MsgBox [sFile] & (" Copied Successfully")

Else
    MsgBox [sFile] & " Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If
'r = r + 1
'Loop
MsgBox "Finished Creating"
End Sub
Sub create_folder()
Sheets("Stress Log").Activate
r = 3
foldname = Cells(r, 1)
MkDir ("C:\Users\vid14865\Desktop\VLM - Sir Earl\3RC430BB VLM - Stress ISOs\" & foldname)

End Sub

这是我到目前为止所拥有的。这将创建文件夹并很好地复制文件，但是文件不会被复制到文件夹中。它被复制到创建的文件之外。