Making a macro that loop through folders

[Vbanoob98]

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

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

 

[Vbanoob98]

Bump