Change code to allow for mutliple file selection

user_10562318 0
Viewed 92

I have been using a macro to import multiple .txt files into my active excel workbook (please see below). I would like to change it in a way that allows me to choose the files to import and otherwise function the same way. I tried using "Application.GetOpenFilename(FileFilter:="Text Files (.txt), .txt", MultiSelect:=True, Title:="Text Files to Open")", but I get a Type Mismatch error. I have a feeling this shouldn't be big issue, but I just cannot seem to fix this problem.

Any suggestions are very much appreciated. 

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
import vba excel file
1 Answers

Please Try your code (it is a fine piece of code) tweaked a little

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

Will be pleased if it helps you. However you may please check existence of worksheet names before naming newly added worksheet and add preventive measure.

user_104057780
Related