Choose and select files to import instead of hardcoded file folder

[Berenloper]

Hi everyone,

I have a working macro for import of csv files where they are presented on different worksheets. In the macro the directory where the csv files are is hardcoded ("fs.GetFolder="). This is the working code:

Dim fs As New FileSystemObject
Dim fo As Folder
Dim fi As File
Dim WB As Workbook
Dim Ws As Worksheet
Dim sname As String

Sub ImportCSV()
Application.ScreenUpdating = False
    Set WB = ThisWorkbook
    Set fo = fs.GetFolder("C:\Users\berenloper\Downloads\CSV\")
    For Each fi In fo.Files
        If UCase(Right(fi.Name, 4)) = ".CSV" Then
            sname = Replace(Replace(fi.Name, ":", "_"), "\", "-")
            Set Ws = WB.Sheets.Add
            sname = Split(fi.Name, ".")(0) 'credit to [URL="https://www.mrexcel.com/forum/excel-questions/1019322-create-sheetnames-based-imported-filenames-without-extension.html?highlight=berenloper"]Matt Mickle[/URL]
            Ws.Name = sname
            Call WizardTexfileImport(fi.Path, Ws)
        End If
    Next
    
    For I = 1 To Application.Sheets.Count
    For j = 1 To Application.Sheets.Count - 1
            If UCase$(Application.Sheets(j).Name) > UCase$(Application.Sheets(j + 1).Name) Then
                Sheets(j).Move After:=Sheets(j + 1)
            End If
    Next
    Next
Application.ScreenUpdating = True
End Sub

Sub WizardTexfileImport(what As String, where As Worksheet)
With Ws.QueryTables.Add(Connection:= _
    "TEXT;" & what, Destination:=Range("$A$4"))
    .Name = "test1"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = True
    .TextFileCommaDelimiter = False
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With
End Sub

The question I have is: "Is it possible to change this so I can choose where and which csv files I want to import?"
I found other code which uses "Application.GetOpenFilename" so I tried the following. But as I have little knowledge of programming it sadly faild.

Dim fs As New FileSystemObject
Dim fo As Folder
Dim fi As File
Dim WB As Workbook
Dim Ws As Worksheet
Dim sname As String
Dim xFilesToOpen As Variant

Sub ImportCSV()
Application.ScreenUpdating = False
xFilesToOpen = Application.GetOpenFilename("Text Files (*.csv), *.xls", , "Import csv", , True)
    If TypeName(xFilesToOpen) = "Boolean" Then
        MsgBox "No files selected", , "Import csv"
        GoTo ExitHandler
    End If
    Set WB = ThisWorkbook
    'Set fo = fs.GetFolder("C:\Users\berenloper\Downloads\CSV\")
    Set fo = xFilesToOpen
    For Each fi In fo
        If UCase(Right(fi.Name, 4)) = ".CSV" Then
            sname = Replace(Replace(fi.Name, ":", "_"), "\", "-")
            Set Ws = WB.Sheets.Add
            sname = Split(fi.Name, ".")(0) 'credit to [URL="https://www.mrexcel.com/forum/excel-questions/1019322-create-sheetnames-based-imported-filenames-without-extension.html?highlight=berenloper"]Matt Mickle[/URL]
            Ws.Name = sname
            Call WizardTextfileImport(fi.Path, Ws)
        End If
    Next
    
    For I = 1 To Application.Sheets.Count
    For j = 1 To Application.Sheets.Count - 1
            If UCase$(Application.Sheets(j).Name) > UCase$(Application.Sheets(j + 1).Name) Then
                Sheets(j).Move After:=Sheets(j + 1)
            End If
    Next
    Next
ExitHandler:
    Application.ScreenUpdating = xScreen
    Exit Sub
ErrHandler:
    MsgBox Err.Description, , "Import csv"
    Resume ExitHandler
Application.ScreenUpdating = True
End Sub

Sub WizardTexfileImport(what As String, where As Worksheet)
With Ws.QueryTables.Add(Connection:= _
    "TEXT;" & what, Destination:=Range("$A$4"))
    .Name = "test1"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = True
    .TextFileCommaDelimiter = False
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With
End Sub

Any help on this would again be appreciated!

Regards,

Berenloper

 

[Berenloper]

Hold on John. I found the problem I think.

Very weird. When copying the code from this board into my editor, the back slash as spoken before disappeares...
Saw it accidental when viewing this thread on my tablet. Never seen this behaviour before. I will test later!

Regards,

Berenloper

 

[Berenloper]

Hello John,

Yes! Finally success
It took me some more puzzling (in the second sub) before I got it working. The missing backslash is something I can't explain. Perhaps someone else knows the reason for this, but it's good to know.

Thanks for your help John. I appreciate it!

Here's the complete code for anyone interested:

Sub ImportCSV()
    Dim fi As Variant
    Dim Ws As Worksheet
    Dim sname As String
    Dim xFilesToOpen As Variant
    
    xFilesToOpen = Application.GetOpenFilename("Text Files (*.csv), *.xls", , "Import csv", , True)

    If TypeName(xFilesToOpen) = "Boolean" Then
        MsgBox "No files selected", , "Import csv"
        Exit Sub
    End If

    Application.ScreenUpdating = False

    For Each fi In xFilesToOpen
        If UCase(Right(fi, 4)) = ".CSV" Then
            sname = Mid(fi, InStrRev(fi, "\") + 1)
            sname = Left(sname, InStrRev(sname, ".") - 1)
            Set Ws = ThisWorkbook.Sheets.Add
            Ws.Name = sname
            Call WizardTextfilesImport(CStr(fi), Ws)
        End If
    Next

'Sorting of sheets...

        For I = 1 To Application.Sheets.Count
        For j = 1 To Application.Sheets.Count - 1
                If UCase$(Application.Sheets(j).Name) > UCase$(Application.Sheets(j + 1).Name) Then
                    Sheets(j).Move After:=Sheets(j + 1)
                End If
        Next
        Next

    Application.ScreenUpdating = True

ExitHandler:
    Application.ScreenUpdating = xScreen
    Exit Sub
ErrHandler:
    MsgBox Err.Description, , "Import csv"
    Resume ExitHandler

End Sub

Sub WizardTextfilesImport(what As String, Ws As Worksheet)
With Ws.QueryTables.Add(Connection:= _
    "TEXT;" & what, Destination:=Range("$A$4"))
    .Name = "test1"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437
    .TextFileStartRow = 1
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = False
    .TextFileTabDelimiter = False
    .TextFileSemicolonDelimiter = True
    .TextFileCommaDelimiter = False
    .TextFileSpaceDelimiter = False
    .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
End With
End Sub

Regards,

Berenloper