vba excel: open files (known filename) from multiple folders - excel

Question

I'm trying to figure out how to import text files (always named tracks.txt) from different folders into one workbook with separate worksheets named after the folder.
basically it should work like this:
select main folder
select multiple sub-folders (which contain the tracks.txt)
or
search in all sub-folders starting with the string (user input)
import tracks.txt in new worksheet
replace worksheetname with subfoldername
would this be possible?

Answer 1

'//-----------------------------------------------------------------------------------------\\
'||code was made with the great help of bsalv and especially snb from www.worksheet.nl ||
'||adjusted and supplemented for original question by myself martijndg (www.worksheet.nl) ||
'\\-----------------------------------------------------------------------------------------//
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select folder with subfolder (containing tracks.txt) NO SPACES IN FILEPATH!!!"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1) + "\" 'laatste slash toegevoegd aan adres
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub importtracks()
Dim subfolder, serie As String
c00 = GetFolder("C:\")
serie = InputBox(Prompt:="partial foldername of serie", _
Title:="find folders of 1 serie", Default:="track##.")
If serie = "track##." Or serie = vbNullString Then
Exit Sub
End If
Workbooks.Add
For Each it In Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir " & c00 & "tracks.txt /b /s").stdout.readall, vbCrLf), ":")
sn = Split(CreateObject("scripting.filesystemobject").opentextfile(it).readall, vbCrLf)
With Sheets
subfolder = Replace(Replace(CreateObject("scripting.filesystemobject").GetParentFolderName(it), "" & c00 & "", ""), "\", "")
End With
If InStr(1, subfolder, serie, vbTextCompare) Then
With Sheets.Add
.Move after:=Sheets(Sheets.Count)
.name = subfolder
.Cells(1).Resize(UBound(sn) + 1) = WorksheetFunction.Transpose(sn)
.Columns(1).TextToColumns , xlDelimited, semicolon:=True
End With
End If
Next
If Sheets.Count = 3 And Sheets(Sheets.Count).name = "Sheet3" Then
MsgBox "no subfolder contained the string '" & serie & "' or your choosen filepath contained spaces"
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Exit Sub
End If
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
Application.DisplayAlerts = True
End Sub