Question

任何人都可以查看以下代码并告诉我哪里出错了？

基本上我想要实现的是，用户在列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

Answer 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

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

1 个答案: