excel - vba excel：从多个文件夹打开文件（已知文件名）

Question

我试图弄清楚如何将不同文件夹中的文本文件（始终命名为tracks.txt）导入到一个工作簿中，其中包含以该文件夹命名的单独工作表。

基本上它应该像这样工作：

• 选择主文件夹

  • 选择多个子文件夹（包含tracks.txt）

    或者

  • 在以字符串开头的所有子文件夹中搜索（用户输入）

• 在新工作表中导入tracks.txt

• 用子文件夹名替换工作表名

这可能吗？

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