Choose and select files to import instead of hardcoded file folder

B

Berenloper

Board Regular
Joined
May 28, 2009
Messages
83
Office Version
  1. 365
Platform
  1. Windows
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:

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.

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
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
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
Change the fi variable to a Variant and use this to loop through the files returned by GetOpenFileName:
Code: 
    'Set fo = fs.GetFolder("C:\Users\berenloper\Downloads\CSV\")
    'Set fo = xFilesToOpen
    For Each fi In xFilesToOpen
        If UCase(Right(fi, 4)) = ".CSV" Then
            sname = Replace(Replace(fi, ":", "_"), "\", "-")
            Set Ws = ThisWorkbook.Sheets.Add
            sname = Split(fi, ".")(0) 'credit to Matt Mickle
            Ws.Name = sname
            Call WizardTextfileImport(CStr(fi), Ws)   '<--- Text, not Tex
        End If
    Next
 
Upvote 0
Hello John_w,

Thanks for helping!
Well spotted: text. Unfortunatly I get error 1004 at line 'Ws.Name = sname' about a not valid filename. Possibility's are: name longer then 31 characters, not valid signs like '\' or an empty name which all not applicable. I guess the part 'sname = Replace(Replace(fi, ":", "_"), "", "-")' has something to do with it?

This is the code now:

Code: 
Dim fs As New FileSystemObject
Dim fo As Folder
Dim fi As Variant
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
    For Each fi In xFilesToOpen
        If UCase(Right(fi, 4)) = ".CSV" Then
            sname = Replace(Replace(fi, ":", "_"), "\", "-")
            Set Ws = ThisWorkbook.Sheets.Add
            sname = Split(fi, ".")(0) 'credit to Matt Mickle
            Ws.Name = sname

            Call WizardTextfileImport(CStr(fi), 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

Any idea how to solve this?

Regards,

Berenloper
 
Upvote 0
Replace "/" with "-" in the full file name:
Code: 
sname = Replace(Replace(Replace(fi, ":", "_"), "\", "-"), "/", "-")
just keep nesting Replaces like this to replace all invalid characters.
 
Upvote 0
John_w,

I get the same error again :(
Ah, I missed your line about every non-valid character. Will give it a try this weekend.

Regards,

Berenloper
 
Last edited:
Upvote 0
John_w,

Did try a few things, but no: same error. The file path and (first) file that I'm selecting is: "C:\Users\berenloper\Downloads\CSV\COKZ_OVZ01.csv"
Is the maximum of 31 characters causing the problem here?

Regards,

Berenloper
 
Upvote 0
Yes, 31 characters is the maximum for a sheet name - fixed by:

Code: 
    sname = Right(sname, 31)

Or if you just want the file name (without the folder path and .csv part) then:

Code: 
    sname = Mid(fi, InStrRev(fi, "\") + 1)
    sname = Left(sname, InStrRev(sname, ".") - 1)
 
Upvote 0
Hi John,


I'm a little confused where to put your code. I would go for filename only, so I changed the last code as below. But I get an error #5 when selecting 1 of more files.


Code: 
Dim fs As New FileSystemObject
Dim fo As Folder
Dim fi As Variant
'Dim WB As Workbook 'don't need this line... ?
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 'don't need this line... ?


    For Each fi In xFilesToOpen
        If UCase(Right(fi, 4)) = ".CSV" Then
        
            sname = Mid(fi, InStrRev(fi, "") + 1)
            sname = Left(sname, InStrRev(sname, ".") - 1) 'gives error [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=5]#5[/URL]  here when selecting 1 or more files
    
            'sname = Replace(Replace(Replace(Replace(fi, ":", "_"), "", "-"), "/", "-"), "*", "-") 'don't need this line... ?
            Set Ws = ThisWorkbook.Sheets.Add
            'sname = Split(fi, ".")(0) 'credit to Matt Mickle 'don't need this line... ?
            Ws.Name = sname
           
            Call WizardTextfilesImport(CStr(fi), Ws)


        End If
    Next


Did I made a mistake? If so, can you point out where?


Thanks and regards,


Berenloper
 
Upvote 0
The back slash character is missing from the first sname = line in your code.

Try this:
Code: 
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
    Application.ScreenUpdating = True

End Sub
 
Upvote 0
Hi John,

Thanks for your patience, but still going wrong.
The back slash character your talking about in the first sname line, where should it be? I don't see it in your code neither.
When exactly executing your last code I get the same error 5 at the second sname. (non-valid procedure call or argument).

Regards,

Berenloper
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
Export excel file as PDF into a targeted pc folder based on cell value
Replies
2
Views
278
Ramadan2512
R
T
  • Solved
CSV import overwriting the next column after the last one in the CSV file
Replies
7
Views
329
Joe4
Joe4
H
  • Question Question
Macro to Open File and limit selection where files contains "Parts" in C
Replies
4
Views
270
howard
H
H
  • Question Question
Macro to select latest modified File
Replies
4
Views
242
Sektor
Sektor
C
  • Question Question
Setting the default save path with prompt
Replies
2
Views
845
CaptainGravyBum
C

Forum statistics

Threads
1,224,823
Messages
6,181,176
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top