VBA с использованием FileDialog в качестве пути к папке в цикле

Question

Я пытаюсь сделать копию рабочей книги на основе списка идентификаторов. У меня это работает нормально, если я жестко запрограммировал путь, однако я не могу понять, как это сделать, если указать путь с помощью msoFileDialogFolderPicker.

Я пробовал несколько вариантов в зависимости от того, что у меня есть нашел в Интернете и попал так далеко, как ниже, но застрял. Помощь оценена.

Dim xFilepath As Variant
Dim xFilename As String
xFilepath = Application.FileDialog(msoFileDialogFolderPicker)
xFilename = Range("Table9[ProgramID]") & " Product Financial Allocation" & ".xlsb"

With xFilepath
    .Title = "Choose Destination"
    .SHOW
    mypath = .SelectedItems(1) & "\"
End With

mypath = mypath

Sheets("FILES").Range("A3").Select

  For i = 1 To 3

Sheets("FILES").Range("A" & i).copy Sheets("TEMPLATE").Range("Table9[ProgramID]")

        ActiveWorkbook.SaveCopyAs Filename:=mypath & Filename
        FileFormat = 50

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Workbooks.Open Filename:=mypath & Filename

    Call DeleteQueries

    ActiveWorkbook.Save
    ActiveWorkbook.Close

  Next i

        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.EnableEvents = True

End Sub

Answer 1

Вы можете использовать следующий код, чтобы выбрать папку, а затем добавить путь к папке с именем файла.

Sub ChooseFolder()
Dim sFolder As String
    ' Open the select folder prompt
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        If .Show = -1 Then ' if OK is pressed
            sFolder = .SelectedItems(1)
        End If
    End With
    Filename = "Test.xlsx"
    Filepath = sFolder + "\" + Filename
    If sFolder <> "" Then ' if a file was chosen
        MsgBox Filepath 'Use this for further processing
    End If
End Sub

Следующий код можно использовать для выбора одного файла.

Private Sub ChooseFile()
    Dim fd As Office.FileDialog

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

   With fd
      .AllowMultiSelect = False
      .Title = "Please select the file."
      .Filters.Clear
      .Filters.Add "Excel File", "*.xlsx"

      If .Show = True Then
        txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
      End If
   End With
   MsgBox txtFileName
End Sub