Trying to loop through multiple docs in a folder, cut out green colored text, paste green text to new doc, save both docs in same folder. Code crashes on .Activate. Set statement is empty. Not sure why?
Code:
Sub FindGreenText()
Application.ScreenUpdating = False
Dim oSel As Range
Dim oResponse As Document
Dim oDoc As Document
Dim strDocName As String, strPath As String, strFile As String, strFolder As String
strFolder = "<folder location with doc files>"
strFile = Dir(strFolder & "\*.docx", vbNormal)
Set oDoc = Documents.Open(FileName:=strFolder & " \ " & strFile, AddToRecentFiles:=False, Visible:=True)
While strFile <> ""
oDoc.Activate 'code stops here with empty set statement
'DoEvents
strDocName = Left(oDoc.Name, InStrRev(oDoc.Name, Chr(46)) - 1)
strDocName = strDocName & "_response.docx"
strPath = oDoc.Path & Chr(92)
Set sel = ActiveDocument.Range
Set oResponse = Documents.Add
With sel.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.MatchWildcards = False
.Forward = True
.Wrap = wdFindStop
.Font.ColorIndex = wdGreen
.Execute
Do Until Not .Found
If sel.Font.ColorIndex = wdGreen Then
sel.Cut
With oResponse
Selection.Range.Paste
Selection.MoveStart unit:=wdParagraph
Selection.TypeParagraph
End With
End If
.Execute
Loop
End With
oDoc.SaveAs2
oResponse.SaveAs2 strPath & strDocName
oDoc.Close
oResponse.Close
strFile = Dir()
Wend
Application.ScreenUpdating = True
MsgBox "Lucy, I'm home!"
End Sub