Search for text in large files without Carriage Return Characters more quickly RRS feed

  • Question

  • I have written code to search for text in text files. They have the extension .DAT

    The code works by:

    1. Locating files in a diectory that wre created of modified in a certain period
    2. Searching for a pair of string in each line
    3. if the strings are both found, then the name of the text file as well as the complete line is written in excel

    Is there anyway to improve the speed for the code? also can i put in a progress bar on approximately how far the process has gone?

    The code:

    Sub LoopThroughFiles()
    Application.ScreenUpdating = False
        Dim StrFile As String 'This is is the name of the File
        Dim Path As String 'Directory of the file
        Dim x As String 'Full path of the string
        Dim LastDate As Date 'The Maximum Date to compare with date modified
        Dim DateModified As Date 'Date when the file was created or modified
        Dim FirstDate As Date 'The minimum date to compare with Date Modified
        Dim fso As New FileSystemObject
        Dim file As TextStream
        Dim textline As String 'Text in each line in the file
        Dim SearchString As String 'String to search for
        Dim SearchString1 As String 'Second string to search for
        Dim y As Long 'Counter used to insert text in excel
        'Assign values to Variables
        Path = "\\omlac-011\COMPEN AUDIT TRAIL NEW ENVIRONMENT\"
        StrFile = Dir(Path & "BM*.DAT")
        FirstDate = CDate(Range("A1"))
        LastDate = CDate(Range("B1"))
        y = 1
        SearchString = Range("c1").Value
        SearchString1 = Range("D1").Value & vbTab
        Do While Len(StrFile) > 0
            x = Path & StrFile
            DateModified = CDate(FileDateTime(x))
            If DateModified > FirstDate And DateModified < LastDate Then
            Set file = fso.OpenTextFile(x, ForReading)
                Do While Not file.AtEndOfLine
                    textline = file.ReadLine
                    If InStr(1, textline, SearchString, vbTextCompare) > 0 And InStr(1, textline, SearchString1, vbTextCompare) > 0 Then
                        Range("A" & y + 2).Value = StrFile
                        Range("B" & y + 2).Value = textline
                        y = y + 1
                    End If
                Set file = Nothing
                Set fso = Nothing
            End If
            StrFile = Dir()
        Range(Selection, Selection.End(xlDown)).Select
     On Error Resume Next
        Selection.TextToColumns Destination:=Range("B3"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False
    Application.ScreenUpdating = True
    End Sub

    Thursday, October 9, 2014 9:50 AM


All replies