将用户选择的多个文件（通过文件对话框）复制到新创建的文件夹

Posted 2023-02-23

【中文标题】将用户选择的多个文件（通过文件对话框）复制到新创建的文件夹

【英文标题】：Copying multiple files selected by user (via filedialog) to newly created folder

【发布时间】：2016-03-03 08:51:08

【问题描述】：

谁能检查下面的代码并告诉我哪里出错了？

基本上我想要实现的是，用户在 A 列中输入名称，然后单击上传按钮（同一行，F 列），excel 将使用 A 列中的名称创建一个文件夹，通过filedialog 窗口用户将选择多个应该复制到新创建的文件夹的文件，最后excel还会另外创建文件夹的路径（保存在D列中）并标记日期（E列）。

当前问题：

复制多个文件失败，目前只能复制一个文件 文件复制到新建文件夹的父文件夹，基本上 无法复制到新创建的文件夹本身。

我的代码：

Sub Button1_Click()

Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Foldername As String
Dim Path As String
Dim Newpath As String
Dim i As Integer
Dim myfile As String
Dim myfilePath As String

Foldername = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -5).Value
Path = "C:\Test\"

Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = True

Set objFSO = CreateObject("Scripting.FileSystemObject")

For i = 1 To openDialog.SelectedItems.Count
    myfile = openDialog.SelectedItems.Item(i)
Next

If openDialog.Show = -1 Then

    If Dir(Path & Foldername, vbDirectory) = "" Then
        MkDir Path & Foldername
    End If

    objFSO.CopyFile myfile, Path

    ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2).Hyperlinks.Add ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2), Address:=Path & Foldername, TextToDisplay:="Open Folder"
    ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -1).Value = Format(Now, "MM/dd/yyyy")

    MsgBox "Files were successfully copied"

End If

End Sub

【参考方案1】：

您的 For 循环位于错误的位置。这就是为什么您无法遍历每个文件并复制它的原因。

您有这个问题，因为您使用了objFSO.CopyFile myfile, Path 而不是新创建的文件夹名称。我用这个改变了那部分：objFSO.CopyFile myfile, Path & Foldername & "\"。请注意Path & Foldername 是不够的，因为您需要在末尾添加\。

工作代码：

Sub Button1_Click()

Dim objFSO As Object
Dim objFile As Object
Dim openDialog As FileDialog
Dim Foldername As String
Dim Path As String
Dim Newpath As String
Dim i As Integer
Dim myfile As String
Dim myfilePath As String

Foldername = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -5).Value
Path = "C:\Test\"

Set openDialog = Application.FileDialog(msoFileDialogFilePicker)
openDialog.AllowMultiSelect = True

Set objFSO = CreateObject("Scripting.FileSystemObject")

If openDialog.Show = -1 Then

    If Dir(Path & Foldername, vbDirectory) = "" Then
        MkDir Path & Foldername
    End If

    For i = 1 To openDialog.SelectedItems.Count
        myfile = openDialog.SelectedItems.Item(i)
        objFSO.CopyFile myfile, Path & Foldername & "\"
    Next

    ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2).Hyperlinks.Add ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -2), Address:=Path & Foldername, TextToDisplay:="Open Folder"
    ActiveSheet.Shapes(Application.Caller).TopLeftCell.Offset(0, -1).Value = Format(Now, "MM/dd/yyyy")

    MsgBox "Files were successfully copied"

End If

Set objFSO = Nothing
Set openDialog = Nothing

End Sub

【讨论】：

非常感谢您的及时回复，感觉有点笨，之前试过了，但是不知道需要加& "\"。再次感谢，现在就知道了。