Копирование нескольких файлов, выбранных пользователем (через filedialog) во вновь созданную папку

Может ли кто-нибудь, пожалуйста, Просмотреть код ниже и сказать мне, где я иду неправильно?

В основном то, что я пытаюсь достичь, пользователь вводит имя в столбце A, затем нажимает кнопку Загрузить (та же строка, столбец F), excel создаст папку, используя имя из столбца A, через окно filedialog пользователь выберет несколько файлов, которые должны быть скопированы в новую папку, наконец excel также дополнительно создаст путь к папке (сохраненный в столбце D) и отметит дату (столбец Ми).

Текущие проблемы:

  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
1 3
excel vba excel-vba folder

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
4