Hi everyone,
Currently when I run this code I have to select the folder where the csv files are and then they will merge into one workbook which will be saved in the same path. Then I have to do it again for 100 folders more.
I want to be able to make a macro that loops through all the folders by itself and saves all of the files in another folder. And if possible it would be nice to be able to make the file created have the same name as the folder thats in it.
So for example
C:\user\ABC\ --->C:\user\All files\ABC.xlsx
C:\user\CBD\ ---> C:\user\All files\CBD.xlsx
And so on
You would save my life if you guys can do this :D
Currently when I run this code I have to select the folder where the csv files are and then they will merge into one workbook which will be saved in the same path. Then I have to do it again for 100 folders more.
I want to be able to make a macro that loops through all the folders by itself and saves all of the files in another folder. And if possible it would be nice to be able to make the file created have the same name as the folder thats in it.
So for example
C:\user\ABC\ --->C:\user\All files\ABC.xlsx
C:\user\CBD\ ---> C:\user\All files\CBD.xlsx
And so on
You would save my life if you guys can do this :D
VBA 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
ActiveWorkbook.Close savechanges:=True
End Sub