I have written working Word VBA code to replace Journal titles by their abbreviations.
The Find and Replace part of the code is very slow for larger documents.
The array of Journal titles and their abbreviations is defined from a tab separated .txt file.
Sub JournalAbbreviator2_5()
Dim findAndReplaceList As Variant
Dim filePath As String
Dim fileContent As String
Dim fileNumber As Integer
Dim lines() As String
Dim i As Integer
Dim parts() As String
Dim j As Integer
Dim temp As Variant
Dim doc As Document
Dim r As Range
' Define the path to the text file
filePath = "..."
' Open the file and read its content
fileNumber = FreeFile
Open filePath For Input As #fileNumber
fileContent = Input$(LOF(fileNumber), fileNumber)
Close #fileNumber
' Remove BOM if present (e.g., UTF-8 BOM)
If Left(fileContent, 3) = ChrW(&HFEFF) Then
fileContent = Mid(fileContent, 4)
End If
' Replace different newline characters
fileContent = Replace(fileContent, vbCrLf, vbLf) ' Convert Windows line endings to Unix
fileContent = Replace(fileContent, vbCr, vbLf) ' Convert Mac line endings to Unix
' Split the content into lines
lines = Split(fileContent, vbLf)
' Initialize the findAndReplaceList array
ReDim findAndReplaceList(LBound(lines) To UBound(lines))
' Process each line
For i = LBound(lines) To UBound(lines)
' Split the line into parts using tab as the delimiter
parts = Split(lines(i), vbTab)
' Add the parts to the array if it contains exactly 2 elements
If UBound(parts) = 1 Then
findAndReplaceList(i) = Array(parts(0), parts(1))
End If
Next i
' Sort findAndReplaceList by the length of the full title in descending order
For i = LBound(findAndReplaceList) To UBound(findAndReplaceList) - 1
For j = i + 1 To UBound(findAndReplaceList)
' Check if both elements are arrays and compare their lengths
If IsArray(findAndReplaceList(i)) And IsArray(findAndReplaceList(j)) Then
If Len(findAndReplaceList(i)(0)) < Len(findAndReplaceList(j)(0)) Then
' Swap elements
temp = findAndReplaceList(i)
findAndReplaceList(i) = findAndReplaceList(j)
findAndReplaceList(j) = temp
End If
End If
Next j
Next i
' Confirm continuation
If MsgBox("Continue with the find and replace operations?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
' Perform find and replace operations with error handling
Set doc = ActiveDocument
Set r = doc.Content
' Turn off screen updating to speed up the process
Application.ScreenUpdating = False
' Perform find and replace operations
For j = LBound(findAndReplaceList) To UBound(findAndReplaceList)
If IsArray(findAndReplaceList(j)) Then
On Error Resume Next ' Ignore errors during find and replace
With r.Find
.Text = findAndReplaceList(j)(0)
.Replacement.Text = findAndReplaceList(j)(1)
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
r.Find.Execute Replace:=wdReplaceAll
On Error GoTo 0 ' Resume normal error handling
End If
Next j
' Re-enable screen updating
Application.ScreenUpdating = True
' Notify user that the process is complete
MsgBox "The find and replace process is complete.", vbInformation
End Sub
I tried turning off screen updating, but that did not make it faster.
The code got substantially faster when I shortened the find and replace list to about 100 items, and updated the code to only do the find and replace in the selected text in the word document using Set r = Selection.Range