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

【问题标题】：vba excel: open files (known filename) from multiple foldersvba excel：从多个文件夹打开文件（已知文件名）
【发布时间】：2013-02-26 15:53:42
【问题描述】：

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

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

选择主文件夹
- 选择多个子文件夹（包含tracks.txt）
  
  或
- 搜索以字符串开头的所有子文件夹（用户输入）
在新工作表中导入tracks.txt
用子文件夹名替换工作表名

这可能吗？

【问题讨论】：

您尝试过使用目录吗？
我不知道这个命令目录或工作方式，你能解释一下吗？
宏需要用于多个文件夹名称和位置，因此用户输入文件夹名称/位置是非常必要的
您希望用户手动选择要打开的文件吗？如果您不需要用户输入，则可以将 VBA 设置为在目录的任何子文件夹中查找任何文件，只要该目录保持不变即可。我想我需要更多细节来帮助。如果不需要，您是否希望用户选择任何内容？如果是这样，您希望用户选择一个文件夹还是选择他想要的每个文件？
tracks.txt 位于每个子文件夹中，例如称为“os1.1”、“os1.2”和“os1.3”需要成为一个 xls 文件，其中包含以其子文件夹名命名的工作表，其中包含来自 tracking.txt 的数据。子文件夹“os2.1”、“os2.2”、“os2.3”也需要合并，但在不同的xls文件中。因此，用户可以选择需要合并到 xls 文件中的文本文件的子文件夹，或者给出所有子文件夹都具有的字符串，例如“os1”

标签： excel vba text import subdirectory

【解决方案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

【讨论】：