復制和重命名動態 excel 工作簿保存 pdf 和 txt 文件

Question

您好，我在一個文件夾中有很多 88795099932388 工作簿和 pdf 和 txt 文檔，我想將它們保存在一個新文件夾（文件夾名稱與 excel 工作簿相同）中，僅包含 pdf 和 txt 文檔，但不包含 excel。

以下代碼只能復制具有特定文件夾名稱的現有文件夾：

Sub FSOCopyFolder()

Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject") 

fso.CopyFolder "C:\User\A", "C:\User\A" 'Dst folder exists
fso.CopyFolder "C:\User\A", "C:\User\A" 'DstNew folder is created

End Sub

我想根據動態excel文件名保存動態文件夾，只有pdf和txt文件。

例如。 文件夾 A-111 有 A-111.xlsm、A-111.pdf 和 A-111.txt，想將 A-111.pdf 和 A-111.txt 文檔復制到新目標文件夾中。

文件夾 B-111 有 B-111.xlsm、B-111.pdf 和 B-111.txt，想將 B-111.pdf 和 B-111.txt 文檔復制到新目標文件夾等

Answer 1

Option Explicit

Sub distributeFile()
Dim FileName As String
Dim fs As Object

Set fs = CreateObject("Scripting.FileSystemObject")
'Debug.Print ActiveWorkbook.Path
FileName = Dir([put here the full path where the files are] & "\*.xlsm")

Do While FileName <> ""
Dim newFolderName As String, fileBaseName
    fileBaseName = fs.getbasename(FileName)
    newFolderName = "C:\User\New\" & fileBaseName & "\"
    If fs.FileExists(ActiveWorkbook.Path & "\" & fileBaseName & ".pdf") Then
        If Not fs.FolderExists(newFolderName) Then fs.CreateFolder (newFolderName)
        fs.movefile ActiveWorkbook.Path & "\" & fileBaseName & ".pdf", newFolderName
    End If
    If fs.FileExists(ActiveWorkbook.Path & "\" & fileBaseName & ".txt") Then
        If Not fs.FolderExists(newFolderName) Then fs.CreateFolder (newFolderName)
        fs.movefile ActiveWorkbook.Path & "\" & fileBaseName & ".txt", newFolderName
    End If
    FileName = Dir()
Loop
Set fs = Nothing
End Sub