Macro to loop in through Word files(.doc), find and delete a section, save and close.

[deluzional]

Hi All,

I really need help with the code below. I am not sure what I am doing wrong with this macro.

I am using Excel VBA to open Word files in a folder, go in each file and delete a section in each .doc; save and close Word, while creating a log in the .cvs file.

Like, I have a section in each file that need to be remove. So the below is basically trying to open each doc, delete the range of text, save, and close app. This will loop through the files until the last file is done.

Help will be much appreciated.


Option Explicit
Public fso As FileSystemObject
Public Const PathToProts As String = "C:\Test\"
' Start
Public Sub Main()
Set fso = New FileSystemObject
Dim wrdApp As Word.Application, wrdDoc As Word.Document
Dim wrdFil As File, fol As Folder, wrdRng As Word.Range, wrdrngStart As Word.Range, wrdrngEnd As Word.Range, rngToDelete As Word.Range
Dim logFile As Scripting.TextStream
If fso.FolderExists(PathToProts) Then
Set fol = fso.GetFolder(PathToProtocols)
Set wrdApp = CreateObject("word.application")
wrdApp.Visible = True
Set logFile = fso.OpenTextFile("C:\Test\ProtsLog.csv", ForAppending, True)
For Each wrdFil In fol.Files
If Right(wrdFil.Name, 4) = ".doc" Then
Set wrdDoc = wrdApp.Documents.Open(PathToProts & "," & wrdFil.Name)
Set wrdRng = wrdDoc.Content
Set wrdrngStart = wrdRng
With wrdrngStart.Find
.ClearFormatting
.Text = "PLEASE DELETE"
.Execute
End With
If wrdrngStart Is Nothing Then
logFile.WriteLine wrdFil.Name & "," & "Missing text - Start of Please Delete"
GoTo nextLoop
End If
Set wrdrngEnd = wrdDoc.Content

With wrdrngEnd.Find
.ClearFormatting
.Text = "End of PLEASE DELETE"
.Execute
End With
If Not wrdrngEnd Is Nothing Then
Set rngToDelete = wrdDoc.Range(wrdrngStart.Start, wrdrngEnd.End)
rngToDelete.Delete
Else

logFile.WriteLine wrdFil.Name & "," & "Missing text - End of Please Delete"
End If
End If

nextLoop:

wrdApp.Documents.Save
wrdDoc.Close False
Set wrdDoc = Nothing
Set wrdApp = Nothing
Next


End If

MsgBox "Finished"
End Sub

[snb]

sub M_snb()
sn=split(createobject("wscript.shell").exec("cmd /c dir C:\Test\*.doc /b").stdout.readall,vbcrlf)

for each it in sn
with getobject("C:\Test\" & it)
if instr(.content,"PLEASE DELETE")=0 then
c00=c00 & vbcrlf & .fullname & " lacks the text: PLEASE DELETE"
.close 0
else
.content=split(.content,"Please Delete")(0) &split(.content,"End of Please delete")(1)
.close -1
end if
end with
next

open "C:\Test\ProtsLog.csv" For Output as #1
print #1,c00
close #1
End Sub

[deluzional]

Thank you for the response. Let me try the code out and give an update.