Измените код, чтобы разрешить выбор файла Mutliple

Question

Я использовал макрос для импорта нескольких файлов .txt в мою активную книгу Excel (см. Ниже). Я хотел бы изменить его таким образом, чтобы я мог выбирать файлы для импорта и в остальном функционировать одинаково. Я пытался использовать " Application.GetOpenFilename (FileFilter: =" Текстовые файлы ( .txt), .txt ", MultiSelect: = True, Название: =" Текстовые файлы для открытия ")", но я получаю ошибку несоответствия типов. У меня такое ощущение, что это не должно быть большой проблемой, но я просто не могу решить эту проблему.

Любые предложения очень ценятся.

Sub TxtImporter()
Dim f As String, flPath As String
Dim i As Long, j As Long
Dim ws As Worksheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False

flPath = ThisWorkbook.Path & Application.PathSeparator
i = ThisWorkbook.Worksheets.Count
j = Application.Workbooks.Count
f = Dir(flPath & "*.txt")

Do Until f = ""
    Workbooks.OpenText flPath & f, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
        Space:=False, Other:=False, TrailingMinusNumbers:=True
    Workbooks(j + 1).Worksheets(1).Copy After:=ThisWorkbook.Worksheets(i)
    ThisWorkbook.Worksheets(i + 1).Name = Left(f, Len(f) - 4)
    Workbooks(j + 1).Close SaveChanges:=False
    i = i + 1
    f = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Answer 1

Пожалуйста, попробуйте свой код ( это тонкий кусочек трески e), слегка подправленный

Sub TextImporter2()
Dim f As String, flPath As String
Dim i As Long, j As Long
Dim ws As Worksheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False

flPath = ThisWorkbook.Path & Application.PathSeparator
i = ThisWorkbook.Worksheets.Count
j = Application.Workbooks.Count

FileNames = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), *.txt", MultiSelect:=True, Title:="Text Files to Open")
If VarType(FileNames) = vbBoolean Then
MsgBox "No Files Selected"
Exit Sub
End If

For Fno = LBound(FileNames) To UBound(FileNames)
    Workbooks.OpenText FileNames(Fno), _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
        Space:=False, Other:=False, TrailingMinusNumbers:=True
    f = ActiveWorkbook.Name
    Workbooks(j + 1).Worksheets(1).Copy After:=ThisWorkbook.Worksheets(i)
    ThisWorkbook.Worksheets(i + 1).Name = Left(f, Len(f) - 4)
    Workbooks(j + 1).Close SaveChanges:=False
    i = i + 1
Next Fno

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Буду рад, если он вам поможет.Тем не менее, вы можете проверить существование имен рабочих таблиц, прежде чем называть новую добавленную рабочую таблицу, и добавить меры предосторожности.