Hello,

I´m trying to create a Macro in Word 2013, but I am completely new to this, so I am hoping somebody can help me.
I have a folder with many subfolders, which are filled with txt-files on a regular basis that have to be formatted in a certain way, saved as pdf and then deleted afterwards.

So, the basic steps of the Macro are:
1. Replace various text parts with predefined alternative words
2. Change the font size to 12, font to Calibri and save as pdf afterwards
3. Delete the txt-files, after they have been saved as pdf

So far, I have been able to collect some code through googling, which allows me to do all these things (in two different macros) but only for the top folder.

So I am hoping that somebody could maybe restructure the code, to have it include the txt-files in the subfolders for all these steps and possibly make one "big" macro out of it, instead of two.

Thank you!!

Kind regards,

NoS


Sub Test()
'
' Test Makro
'
'
Dim File
Dim path As String
path = "C:\Test\"
' note the "\"

File = Dir(path & "*.txt")
Do While File <> ""
Documents.Open FileName:=path & File
With ActiveDocument

With .Range.Find
.Text = "</p></li> </ul> <p>"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll


End With

With .Range.Find
.Text = "</p></li> <li><p>"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "</p> <ul> <li><p>"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "</li> </ul> <p>"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "</p> <ul> <li>"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "</p> </div>"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "</p> <p>"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "</p>"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "</em>"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "<em>"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "</strong>"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "<strong>"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "<a"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "</a></strong>"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "href=*>"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "<div class=""md""><p>"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "'"
.Replacement.Text = "'"
.Execute Replace:=wdReplaceAll
End With

With .Range.Find
.Text = "&quot;"
.Replacement.Text = "”"
.Execute Replace:=wdReplaceAll
End With



'Following code changes the font size to 12, the font to Calibri, the extension of the opened txt file to pdf, without displaying the pdf
Selection.WholeStory
Selection.Font.Size = 12
Selection.Font.Name = "Calibri"
ActiveDocument.Save
pdfFileName = ActiveDocument.FullName ' get the current file name
lengthFileName = Len(pdfFileName) ' get the length of the current file name (includes the path)
pdfFileName = Left(pdfFileName, lengthFileName - 3) + "pdf" ' changes the extension (shave off three characters and add three new ones.)


ActiveDocument.ExportAsFixedFormat OutputFileName:=pdfFileName, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
.Close
End With
File = Dir()
Loop
End Sub










Sub Delete_txt_files()
'Be sure that no file is open in the folder
Dim FSO As Object
Dim MyPath As String
Dim File As Object
Dim Folder As Object
Dim SubFolder As Object

Set FSO = CreateObject("scripting.filesystemobject")

MyPath = "C:\Test\" '<< Change

If Right(MyPath, 1) = "\" Then
MyPath = Left(MyPath, Len(MyPath) - 1)
End If

If FSO.FolderExists(MyPath) = False Then
MsgBox MyPath & " doesn't exist"
Exit Sub
End If

On Error Resume Next
'Delete files
FSO.deletefile MyPath & "\*.txt", True


End Sub
'Option Explicit

Try:
I have some doubts about your process, though. One of your Find/Replace finds is to replace all instances of "</a></strong>" with nothing. However, since you've already replaced all instances of "</strong>" with nothing, this latter find will never locate anything. Similarly, you have another Find/Replace that just replaces "'" with itself. I've left both in the code, but you might need to reconsider your Find/Replace sequencing for the first one and its meaningfulness for the second one.

As coded, the macro includes a folder browser so you can choose the top folder to process.

__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]

Thank you very much, macropod!
As for the first find/replace problem you found, I think you are correct and something got mixed up. I´ll look into it.
As for replacing "'" with itself, it seems that by copying the code here, the forum changed the html-way of writing "'", which I have in the txt files, automatically to the correct way of displaying the character, which is basically the same thing I am doing in the txt files. So it may seem unnecessary but at least to this one there is some logic

As for the code, there still seems to be a problem. I apologize if I did not understand correctly or if am being stupid here, but if I paste it into the VBA editor and then run sub "Main", I get to the part, where it asks me for the top folder. After selecting it, I get a runtime error 424 "object required" though. Do you have any idea why?

Also, could you change the popup asking to select the location to a fixed one in the code? I understand that your solution is much more elegant but the folder will never change and thus I can save a few more clicks during the day.

Once again, thank you for your help!

I don't get the a runtime error 424 "object required". Perhaps you made an error in copying the code.

To skip the folder browser, replace:
Dim StrFolder As String
with:
Const StrFolder As String = "C:\Test"
and delete:
' Browse for the starting folder
StrFolder = GetTopFolder
If StrFolder = "" Then Exit Sub

You can also delete the GetTopFolder function.

__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]

So, I figured out what I did wrong. I´d created a new Macro and then copied your code in there, however I had to post it under a new Module instead to work. Once I´d done that, it worked like a charm! Once again, thank you very much!!