Question

我之前得到了帮助，可以通过文件夹中的多个文本文件来读取数据并在电子表格中组织数据。我从@trincot那里得到了这个脚本，这个脚本很适合我的需要。 How to import specific text from files in to excel?

Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder, file As file, FileText As TextStream
Dim TextLine As String
Dim cl As Range

Dim num As Long ' numerical part of key, as in "Ann:"
Dim col As Long ' target column in Excel sheet
Dim key As String ' Part before ":"
Dim value As String ' Part after ":"

' Get a FileSystem object
Set fso = New FileSystemObject

' Get the directory you want
Set folder = fso.GetFolder("D:\YourDirectory\")

' Set the starting point to write the data to
' Don't write in first row where titles are
Set cl = ActiveSheet.Cells(2, 1)

' Loop thru all files in the folder
For Each file In folder.Files
    ' Open the file
    Set FileText = file.OpenAsTextStream(ForReading)

    ' Read the file one line at a time
    Do While Not FileText.AtEndOfStream

        TextLine = FileText.ReadLine 'read line

        key = Split(TextLine & ":", ":")(0)
        value = Trim(Mid(TextLine, Len(key)+2))
        num = Val(Mid(key,2))
        If num Then key = Replace(key, num, "") ' Remove number from key
        col = 0
        If key = "From" Then col = 1
        If key = "Date" Then col = 2
        If key = "A"    Then col = 2 + num
        If col Then
            cl.Offset(, col-1).Value = value ' Fill cell
        End If
    Loop

    ' Clean up
    FileText.Close
    ' Next row
    Set cl = cl.Offset(1) 
Next file
End Sub

我后来发现的问题是我的文本文件会及时开始存储在子文件夹中的子文件夹中，并且不会编写此脚本来处理此问题。

我在@Cor_Blimey Loop Through All Subfolders Using VBA

找到了这个脚本

Public Sub NonRecursiveMethod()
Dim fso, oFolder, oSubfolder, oFile, queue As Collection

Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder("your folder path variable") 'obviously replace

Do While queue.Count > 0
    Set oFolder = queue(1)
    queue.Remove 1 'dequeue
    '...insert any folder processing code here...
    For Each oSubfolder In oFolder.SubFolders
        queue.Add oSubfolder 'enqueue
    Next oSubfolder
    For Each oFile In oFolder.Files
        '...insert any file processing code here...
    Next oFile
Loop

End Sub

这两个答案来自{L42和@chris nielsen Loop through all subfolders and files under a folder and write the last modifed date information to an Excel spreadsheet。

我还尝试了TraversFolder function，但我无法将这些解决方案中的任何一个纳入我现有的脚本中。任何帮助将非常感激！

Answer 1

将您的功能放在标有“此处为您的阅读代码”的部分功能是我在项目中使用的功能之一。我删除了剩余的代码，它应该完成它的任务。

Sub index()
ThisWorkbook.Save
DoEvents
Dim intResult As Integer
Dim strPath As String
Dim objFSO As Object
Dim intCountRows As Integer

Application.FileDialog(msoFileDialogFolderPicker).Title = "Vyberte prosím složku"
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Vybrat složku"
Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = True

intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
If intResult = 0 Then
    End
End If
For Each Item In Application.FileDialog(msoFileDialogFolderPicker).SelectedItems
        strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) 'ulož cestu ke složce
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        intCountRows = GetAllFiles(strPath, ROW_FIRST, objFSO)
        Call GetAllFolders(strPath, objFSO, intCountRows)
Next Item
End Sub

Private Function GetAllFiles(ByVal strPath As String, ByVal intRow As Integer, ByRef objFSO As Object) As Integer
DoEvents
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer

i = intRow + 1
Set objFolder = objFSO.GetFolder(strPath)

For Each objFile In objFolder.Files
        If Right(objFile.Name, 3) = "txt" Then
                    'HERE COMES YOU READING CODE
                    i = i + 1
        End If
Next objFile
GetAllFiles = i + ROW_FIRST - 1

End Function

Private Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object, ByRef intRow As Integer)
DoEvents
Dim objFolder As Object
Dim objSubFolder As Object
Set objFolder = objFSO.GetFolder(strFolder)
For Each objSubFolder In objFolder.subfolders
        intRow = GetAllFiles(objSubFolder.Path, intRow, objFSO)
        Call GetAllFolders(objSubFolder.Path, objFSO, intRow)
Next objSubFolder
End Sub

更新VBA脚本以搜索子文件夹excel

1 个答案: