excel - 将用户选择的多个文件(通过文件对话框)复制到新创建的文件夹

Question

任何人都可以检查下面的代码并告诉我哪里出了问题吗？

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

当前问题:

1. 无法复制多个文件，目前只能复制一个文件
2. 文件基本上被复制到新创建的文件夹的父文件夹中 无法复制到新创建的文件夹本身。

我的代码:

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

Answer 1

1. 您的For循环放错了地方。这就是为什么您无法循环遍历每个文件并复制它。

2. 您遇到此问题是因为您使用了 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