Search for strings/words, filename and extract int

Question

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) 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) 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

Here is the code

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!

Answer 1

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

For Each File In Folder.Files

Write:

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) 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

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