0

テキスト ファイル (常に track.txt という名前) を別のフォルダーから 1 つのワークブックにインポートし、そのフォルダーにちなんで名付けられた別のワークシートを作成する方法を見つけようとしています。

基本的には次のように動作するはずです：

  • メインフォルダを選択

    • 複数のサブフォルダー (tracks.txt を含む) を選択します

      また

    • 文字列で始まるすべてのサブフォルダーを検索します (ユーザー入力)

  • 新しいワークシートに track.txt をインポートします

  • ワークシート名をサブフォルダー名に置き換えます

これは可能でしょうか？

4

1 に答える 1

0 
'//-----------------------------------------------------------------------------------------\\
'||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
于 2013-03-13T15:05:48.973 に答える