none
Loop Through all Word Files in a Folder and Wirte 'Yes' if a String is Found RRS feed

  • Question

  • I'm working on a personal project where I can loop through all word files in a folder, open each, read all the contents, and then if a string is found, write 'Yes' into the sell below the string I'm trying to match on. These are a bunch of resumes.

    So, here's my setup: Range("A1:K1")

    Resume Name:    CCAR    RMBS    SPSS    SAS    FRM    CFA    MBA    .NET    Access    SQL

    I want to write the name of the word file in ColumnA.  So, I open the first file and write the name of the file to cell A2 and if the person lists 'SPSS' and 'SAS' as skills (or this string is found anywhere in the word doc), put 'Yes' into cells D2 & E2.  Below is the code that I was experimenting with.

    Sub OpenAndReadWordDoc()
    ' assumes that the previous procedure has been executed
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim tString As String, tRange As Word.Range
    Dim p As Long, r As Long
    Dim sFolder As String
    Dim strFilePattern As String
    
    
        r = 2 ' startrow for the copied text from the Word document
        Set wrdApp = CreateObject("Word.Application")
        'wrdApp.Visible = True
        sFolder = "C:\Users\rshuell001\Desktop\Resumes\"
        
        '~~> This is the extention you want to go in for
        strFilePattern = "*.doc*"
        
        '~~> Establish an Word application object
        On Error Resume Next
        Set oWordApp = GetObject(, "Word.Application")
    
        If Err.Number <> 0 Then
            Set oWordApp = CreateObject("Word.Application")
        End If
        Err.Clear
        On Error GoTo 0
    
        oWordApp.Visible = True
    
        '~~> Loop through the folder to get the word files
        strFileName = Dir$(sFolder & strFilePattern)
        Do Until strFileName = ""
            sFileName = sFolder & strFileName
    
            '~~> Open the word doc
            Set oWordDoc = oWordApp.Documents.Open(sFileName)
    
        Dim ws As Worksheet
        For Each ws In ThisWorkbook.Worksheets
        Dim c As Range
             For Each c In ws.UsedRange.Rows(1).Cells
                 c.Value = WorksheetFunction.Trim(c.Value)
                 TestPos = InStr(tString, c.Value)
                                 
                     With oWordDoc
                         For p = 1 To .Paragraphs.Count
                             Set tRange = .Range(Start:=.Paragraphs(p).Range.Start, End:=.Paragraphs(p).Range.End)
                             tString = tRange.Text
                             tString = Left(tString, Len(tString) - 1)
                             
                             Debug.Print tString
                             Set tRange = .Range(Start:=.Paragraphs(p).Range.Start, End:=.Paragraphs(p).Range.End)
                             'Page = tRange.Information(wdActiveEndPageNumber)
            
                             If TestPos > 0 Then
                                 ' fill into active worksheet
                                 ActiveSheet.Range("A" & r).Value = sFileName
                                 ActiveSheet.Range("B" & r).Value = tString
                                 r = r + 1
                             End If
                         Next p
                         .Close ' close the document
                     End With
                
              Next c
        Next ws
                        
                '~~> Close the file after saving
                'oWordDoc.Close SaveChanges:=False
    
                '~~> Find next file
                strFileName = Dir$()
       
        Loop
        
            ' close the Word application
        Set wrdDoc = Nothing
        Set wrdApp = Nothing
        On Error Resume Next
        wrdApp.Quit
        
    
    End Sub
    
    

    Something is definitely wrong with one of my loops, but I'm not sure what the problem is.

    Any thoughts, anyone?


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Tuesday, August 11, 2015 6:47 PM

Answers

  • Sub OpenAndReadWordDoc()
        ' assumes that the previous procedure has been executed
        Dim oWordApp As Word.Application
        Dim oWordDoc As Word.Document
        Dim blnStart As Boolean
        Dim r As Long
        Dim sFolder As String
        Dim strFilePattern As String
        Dim strFileName As String
        Dim sFileName As String
        Dim ws As Worksheet
        Dim c As Long
        Dim n As Long
    
        '~~> Establish an Word application object
        On Error Resume Next
        Set oWordApp = GetObject(, "Word.Application")
        If Err Then
            Set oWordApp = CreateObject("Word.Application")
            ' We started Word for this macro
            blnStart = True
        End If
        On Error GoTo ErrHandler
    
        Set ws = ActiveSheet
        r = 1 ' startrow for the copied text from the Word document
        ' Last column
        n = ws.Range("A1").End(xlToRight).Column
    
        sFolder = "C:\Users\rshuell001\Desktop\Resumes\"
        '~~> This is the extension you want to go in for
        strFilePattern = "*.doc*"
        '~~> Loop through the folder to get the word files
        strFileName = Dir(sFolder & strFilePattern)
        Do Until strFileName = ""
            sFileName = sFolder & strFileName
    
            '~~> Open the word doc
            Set oWordDoc = oWordApp.Documents.Open(sFileName)
            ' Increase row number
            r = r + 1
            ' Enter file name in column A
            ws.Cells(r, 1).Value = sFileName
            ' Loop through the columns
            For c = 2 To n
                If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
                        MatchWholeWord:=True, MatchCase:=False) Then
                    ' If text found, enter Yes in column number c
                    ws.Cells(r, c).Value = "Yes"
                End If
            Next c
            oWordDoc.Close SaveChanges:=False
    
            '~~> Find next file
            strFileName = Dir
        Loop
    
    ExitHandler:
        On Error Resume Next
        ' close the Word application
        Set oWordDoc = Nothing
        If blnStart Then
            ' We started Word, so we close it
            oWordApp.Quit
        End If
        Set oWordApp = Nothing
        Exit Sub
    
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub

    Try this version:


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Proposed as answer by André Santo Tuesday, August 11, 2015 8:22 PM
    • Marked as answer by ryguy72 Tuesday, August 11, 2015 8:38 PM
    Tuesday, August 11, 2015 8:12 PM

All replies

  • Why do you loop through the worksheets of the active workbook?

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, August 11, 2015 7:34 PM
  • LOL!!  Just noticed that!!  That's a mistake!  That's not the problem though.

    Initially i thought there was a problem with the loop, but as I look at it closer, it seems like the problem lies here:

    TestPos = InStr(1, tString, c.Value)

    It seems like that is never evaluated to true, but it definitely should be.

    Also, the columns need to be dynamic here:

    ActiveSheet.Range("B" & r).Value

    The 'r' is fine, but the 'B' needs to be dynamic relative to the strings in Row1.


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.


    • Edited by ryguy72 Tuesday, August 11, 2015 7:51 PM
    Tuesday, August 11, 2015 7:50 PM
  • Sub OpenAndReadWordDoc()
        ' assumes that the previous procedure has been executed
        Dim oWordApp As Word.Application
        Dim oWordDoc As Word.Document
        Dim blnStart As Boolean
        Dim r As Long
        Dim sFolder As String
        Dim strFilePattern As String
        Dim strFileName As String
        Dim sFileName As String
        Dim ws As Worksheet
        Dim c As Long
        Dim n As Long
    
        '~~> Establish an Word application object
        On Error Resume Next
        Set oWordApp = GetObject(, "Word.Application")
        If Err Then
            Set oWordApp = CreateObject("Word.Application")
            ' We started Word for this macro
            blnStart = True
        End If
        On Error GoTo ErrHandler
    
        Set ws = ActiveSheet
        r = 1 ' startrow for the copied text from the Word document
        ' Last column
        n = ws.Range("A1").End(xlToRight).Column
    
        sFolder = "C:\Users\rshuell001\Desktop\Resumes\"
        '~~> This is the extension you want to go in for
        strFilePattern = "*.doc*"
        '~~> Loop through the folder to get the word files
        strFileName = Dir(sFolder & strFilePattern)
        Do Until strFileName = ""
            sFileName = sFolder & strFileName
    
            '~~> Open the word doc
            Set oWordDoc = oWordApp.Documents.Open(sFileName)
            ' Increase row number
            r = r + 1
            ' Enter file name in column A
            ws.Cells(r, 1).Value = sFileName
            ' Loop through the columns
            For c = 2 To n
                If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
                        MatchWholeWord:=True, MatchCase:=False) Then
                    ' If text found, enter Yes in column number c
                    ws.Cells(r, c).Value = "Yes"
                End If
            Next c
            oWordDoc.Close SaveChanges:=False
    
            '~~> Find next file
            strFileName = Dir
        Loop
    
    ExitHandler:
        On Error Resume Next
        ' close the Word application
        Set oWordDoc = Nothing
        If blnStart Then
            ' We started Word, so we close it
            oWordApp.Quit
        End If
        Set oWordApp = Nothing
        Exit Sub
    
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub

    Try this version:


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Proposed as answer by André Santo Tuesday, August 11, 2015 8:22 PM
    • Marked as answer by ryguy72 Tuesday, August 11, 2015 8:38 PM
    Tuesday, August 11, 2015 8:12 PM
  • You are so amazing!!

    Thanks so, so, so much!!!!


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Tuesday, August 11, 2015 8:38 PM