Hello, VBAer!
It was my pleasure to join you here. I was searching for a macro to help with a school project. Basically, we have a term list in Excel, and the goal is to highlight all the terms in a new article saved in Word. All Excel and Word are in Chinese. (So please support Unicode.)
I found macropod's macro from an earlier thread here titled "Help With VBA For A Large Search and Replace Operation, Problem with .MatchWholeWord" (I didn't have enough post count to post the link, Sorry!)
To match that macro, I resaved the list in .doc (Checklist.doc) and ran the macro (below) on my project but it said:"error:no document open"--but I had both docs open.
It's my first time using macro, I may have made some silly mistakes! Please help me out!
Plus, if the term list can be retained in Excel, that would be fantastic.
Thank you!
Julia
--------------------------------
Sub Anonymiser()
Application.ScreenUpdating = False
Dim FileList As Variant, ChkDoc As Document, TestDoc As Document, FilePath As String, ChkList As String, j As Long
'Load the strings from the reference doc into a text string to be used as an array.
Set ChkDoc = Documents.Open("C:\Users\Julia\Desktop\TERM TEST\Checklist.doc")
ChkList = ChkDoc.Range.Text
ChkDoc.Close False
Set ChkDoc = Nothing
'Get the path to the documents to process
FilePath = InputBox("Please input the path to the documents to process", "Path to Files", ActiveDocument.Path)
'Exit if the filepath is empty
If FilePath = "" Then GoTo Done
'Ensure the filepath ends with "\"
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
'Get a list of all documents in the target folder
FileList = Dir(FilePath & "*.doc", vbNormal)
'Process each found file
While FileList <> ""
Set TestDoc = Documents.Open(FilePath & FileList)
With TestDoc.Range.Find
.ClearFormatting
With .Replacement
.ClearFormatting
.Font.Color = wdColorRed
.Text = "[Chinese]"
End With
.MatchWholeWord = True
.MatchCase = True
'Process each word from the Check List
For j = 0 To UBound(Split(ChkList, vbCr))
.Text = Split(ChkList, vbCr)(j) & "'s"
.Execute Replace:=wdReplaceAll
.Text = Split(ChkList, vbCr)(j)
.Execute Replace:=wdReplaceAll
Next
End With
TestDoc.Close True
FileList = Dir()
Wend
'Clean up and exit
Done:
Set TestDoc = Nothing
Application.ScreenUpdating = True
End Sub
Reply With Quote
