搜索字符串/单词，文件名并使用fso提取到新表中 [英] Search for strings/words, filename and extract into new sheet using fso

问题描述

我之前曾问过一个与我正在发帖的新问题有关的问题，并且在同伴的帮助下，所以它的作用是循环遍历一个文件夹，并将指定范围提取到一个新创建的excel工作表中.但是我仍然面临2个问题，

I have previously asked an question related to this new question i am posting and with the help of a fellow mate, so what it does is it loops through a folder and extracts the specified range into a newly created excel sheet. However there's still 2 problems i'm facing,

1)如何获取文件夹中的所有文件名(例如6个文件)并将其写入具有相同格式的复制范围旁边的新创建的工作表中? Header = E1和从E2开始的文件名.

1) how can i get all the file names e.g 6 files in the folder and write it into the new created worksheet right beside the copied ranges with the same format? Header=E1 and the filename from E2 onwards.

2)有没有一种方法可以搜索文件夹中所有文件中的字符串/单词，然后再次执行相同的操作，将它们也以相同的格式提取到新创建的工作表中

2) Is there a way to search for strings/words in all of the files in the folder and do the same thing again which is extract them into the new created sheet as well in the same format

这是代码

Option Explicit

Sub ScanFiles()

    Application.ScreenUpdating = False

    Dim wkb As Workbook
    Set wkb = ThisWorkbook

    Dim wks As Worksheet
    Set wks = Worksheets.Add
    wks.Name = "NewWorksheet"

    ' Add Worksheet to accept data
    With wks
        '.Range("A2:I20").ClearContents -> No longer needed as you create a new sheet
        .Range("A1:D1") = Array("Test", "Temp", "Start", "Type")
    End With

    ' Set your copy ranges
    Dim CopyRange(1 To 4) As String
    CopyRange(1) = "A18"
    CopyRange(2) = "A19"
    CopyRange(3) = "A14"
    CopyRange(4) = "A19"

    ' Early Binding - Add "Microsoft Scripting Runtime" Reference
    Dim FSO As New Scripting.FileSystemObject

    ' Set FolderPath
    Dim FolderPath As String
    FolderPath = "c:\Users\Desktop\Tryout\"

    ' Set Folder FSO
    Dim Folder As Scripting.Folder
    Set Folder = FSO.GetFolder(FolderPath)

    ' Loop thru each file -> Assuming only 6 files 
    Dim File As Scripting.File
    For Each File In Folder.Files

        Dim wkbData As Workbook
        Set wkbData = Workbooks.Open(File.path)

        Dim wksData As Worksheet
        Set wksData = wkbData.Worksheets("Sheet1") ' -> Assume this file has only 1 worksheet

        Dim BlankRow As Long
        BlankRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row + 1

        Dim i As Long
        For i = 1 To 4
            wks.Cells(BlankRow, i).Value = wksData.Range(CopyRange(i)).Value
        Next i

        wkbData.Close False

    Next File

    Range("A:I").EntireColumn.AutoFit
    Application.ScreenUpdating = True

End Sub

感谢任何帮助！如果能够提供一小部分代码，那就更好了！

Appreciate any help! would be even better if able to provide small part of the code!

推荐答案

1)FSO具有一些出色的功能.其中之一是.Name.在此行之后:

1) FSO has some great features. One of them is .Name. Straight after this line:

For Each File In Folder.Files

写:

Debug.Print File.Name

在即时窗口中，您将看到文件的名称.然后，您可以通过简单的引用将结果复制到工作表中，如下所示:

In the immeadiate window you will see the name of the file. You can then copy the result to a worksheet by simple reference, like this:

wks.Range("E1").Value = File.Name

并且标题只是将这一行修改为:

And the header simply ammend this line:

.Range("A1:D1") = Array("Test", "Temp", "Start", "Type")

2)要搜索最快最简单的单词，就是使用like函数.同样，您将使用与以前相同的方法，但使用If语句.

2) To search for words the quickest and easiest is to use the like function. Again you would use the same method as before but using an If statement.

If File.Name Like "*SomeString*" Then
    wksFSO.Cells(1, 1) = File.Name
End If

请注意在sear字符串之前和之后使用通配符*.随意修改它.很明显，我的结果指向单个单元格.如果期望很多，则可以更新它，以便在期望更多结果的情况下将其写入新行.要将它们提取到新的Worksheet中，我首先设置Worksheet并复制名称.像这样:

Note the use of wildcard * before and after the sear string. Modify this as you like. Its obvious I have the results pointing to a single cell. If you expect many then you can update this to write to a new line if more results are expected. To extract them to a new Worksheet I'd first set up the Worksheet and copy the names. Like this:

Worksheets.Add

现在将所有内容包装到相同的代码中，如下所示:

Now to wrap all this up into the same code it could be written like:

Option Explicit

Sub ScanFiles()

    Application.ScreenUpdating = False

    Dim wks As Worksheet
    Set wks = Worksheets.Add
    wks.Name = "NewWorksheet"

    ' New worksheet for question 2
    Dim wksFSO As Worksheet
    Set wksFSO = Worksheets.Add
    wksFSO.Name = "FSOWorksheet"

    ' Add headers data
    With wks
        .Range("A1:E1") = Array("Test", "Temp", "Start", "Type", "FileName")
    End With

    ' Set your copy ranges
    Dim CopyRange(1 To 4) As String
    CopyRange(1) = "A18"
    CopyRange(2) = "A19"
    CopyRange(3) = "A14"
    CopyRange(4) = "A19"

    ' Early Binding - Add "Microsoft Scripting Runtime" Reference
    Dim FSO As New Scripting.FileSystemObject

    ' Set FolderPath
    Dim FolderPath As String
    FolderPath = "c:\Users\Desktop\Tryout\"

    ' Set Folder FSO
    Dim Folder As Scripting.Folder
    Set Folder = FSO.GetFolder(FolderPath)

    ' Loop thru each file -> Assuming only 6 files
    Dim File As Scripting.File
    For Each File In Folder.Files

        ' If loop looking for specific files and copy to new FSOWorksheet
        If File.Name Like "*SomeString*" Then
            wksFSO.Cells(1, 1) = File.Name
        End If

        Dim wkbData As Workbook
        Set wkbData = Workbooks.Open(File.Path)

        Dim wksData As Worksheet
        Set wksData = wkbData.Worksheets("Sheet1") ' -> Assume this file has only 1 worksheet

        Dim BlankRow As Long
        BlankRow = wks.Range("A" & wks.Rows.Count).End(xlUp).row + 1

        Dim i As Long
        For i = 1 To 4
            wks.Cells(BlankRow, i).Value = wksData.Range(CopyRange(i)).Value
        Next i

        ' Write filename in col E
        wks.Cells(BlankRow, 5).Value = File.Name

        wkbData.Close False

    Next File

    Range("A:I").EntireColumn.AutoFit
    Application.ScreenUpdating = True

End Sub

这篇关于搜索字符串/单词，文件名并使用fso提取到新表中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！