复制和重命名动态 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