Quantcast
Channel: Active questions tagged excel - Stack Overflow
Viewing all articles
Browse latest Browse all 88835

Find String and extract in vba using fso

$
0
0

so my code currently goes through a folder and extracts Ranges of data from every file in the folder into a format set by me, it also extracts the filename. Now i need to use fso to search for certain string inside the file not the filename, lets say "Smart", and in the file "Smart" appears quite a few times, but i only want to extract it once.

Thank you so much to anyone who is able to provide me the small part of the code or some advices to help me continue on!

Option Explicit

Sub ScanFiles()

    Application.ScreenUpdating = False

    Dim wks As Worksheet
    Set wks = Worksheets.Add

    ' New worksheet for question 2
    Dim wksFSO As Worksheet

    ' Add headers data
    With wks
        .Range("A1:E1") = Array("Test", "Temp", "Start", "Type", "FileName", "Test", "EndDate", "Smart", "Er")
    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 "ReportFile" Then
            wksFSO.Cells(1, 1) = File.Name
        End If

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

        Dim wksData As Worksheet
        ActiveSheet.Name = "Sheet1"
        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

Viewing all articles
Browse latest Browse all 88835

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>