Save file as folder name/sheets as file name

Vbanoob98

Board Regular
Joined
Sep 13, 2019
Messages
52
Hi I would like to change this code to save the file as the folders name instead of "Total Results.xlsm"

Also I'm trying to name the worksheets the same as the files that its importing instead of "Data" & i +1

Thanks a lot to anyone that can help


Code:
Sub ImportCSVData()

Dim wb As Workbook
Dim wbCSV As Workbook
Dim myPath As String
Dim myFile As Variant
Dim fileType As String
Dim i As Integer

'Get Target Folder Path From User
 With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Source Folder"
        .AllowMultiSelect = False
        .Show
'  changed the following line - added the backslash to the path
        myPath = .SelectedItems(1) & "\"
    End With

'Specify file type
  fileType = "*.csv*"

'Target Path with file type
  myFile = Dir(myPath & fileType)

'Add Target Workbook
 Workbooks.Add
'  changed the following line - removed leading space in file name
 ActiveWorkbook.SaveAs Filename:= _
        myPath & "Total Results.xlsm", FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
'  changed the following line - removed leading space in file name
Set wb = Workbooks.Open(myPath & "Total Results.xlsm")

'Loop through each Excel file in folder
'  changed the following line - to test myFile against a null string, rather than a value of 0
  Do While myFile <> ""
    Worksheets.Add(Before:=Worksheets("Sheet1")).Name = "Data " & i + 1
'changed the following line - from *.csv to myFile ** This was probably what was causing the error
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & myPath & myFile _
            , Destination:=ActiveSheet.Range("$A$1"))
            .Name = myFile
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 850
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = True
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
            1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False    'Error occurs here!
        End With
    i = i + 1
    myFile = Dir
    
  Loop

'Message Box when tasks are completed
  MsgBox "Result Import Complete"

End Sub
 

daverunt

Well-known Member
Joined
Jul 9, 2009
Messages
1,717
Hi,

I've just posted the code where changes are made...

Code:
'  changed the following line - added the backslash to the path
myPath = .SelectedItems(1) & "\"
a = Split(myPath, "\")
myFolderName = a(UBound(a) - 1)

    End With

'Specify file type
  fileType = "*.csv*"

'Target Path with file type
myFile = Dir(myPath & fileType)
myFileName = (Left(myFile, Len(myFile) - 4))
 

'Add Target Workbook
Workbooks.Add
' changed the following line - removed leading space in file name
ActiveWorkbook.SaveAs Filename:= _
myPath & myFolderName, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
' changed the following line - removed leading space in file name
Set wb = Workbooks.Open(myPath & myFolderName)

'Loop through each Excel file in folder
' changed the following line - to test myFile against a null string, rather than a value of 0
Do While myFile <> ""
    Worksheets.Add(Before:=Worksheets("Sheet1")).Name = myFileName
 

Forum statistics

Threads
1,078,338
Messages
5,339,638
Members
399,317
Latest member
mLife

Some videos you may like

This Week's Hot Topics

Top