Hello, I'm a newbie in VBA and I have made this code (probably with a lot of errors) but takes 5 min to run completely.
I already tried to change somethings but always mess up.
Can someone help me?
I already tried to change somethings but always mess up.
Can someone help me?
VBA Code:
Option Explicit
Sub ReplaceWordsBetweenAngleBrackets()
'Get the starting time
Dim startTime As Double
startTime = Timer
Dim wordApp As Word.Application
Dim wordDoc As Object
Dim wordRange As Object
Dim totalReplacements As Long
Dim ws As Worksheet
Dim searchValue As String
Dim replaceValue As Variant
Dim fld As Object
Dim i As Long
Dim excelApp As Excel.Application
Dim excelWorkbook As Object
Dim excelAApp As Excel.Application
Dim excelWWorkbook As Object
Dim ms As Worksheet
Dim sourcePath As String
Dim destPath As String
Dim FSO As Object
Dim filePath As String
Dim fileName As String
Set excelAApp = New Excel.Application
Set excelApp = New Excel.Application
Dim k As Integer, Artcnt As Integer
Dim wdSec As Object
Dim wdHF As Object
Dim wdRng As Object
Dim Section As Object
Dim HeaderFooter As Object
'Open the Word file
Set wordApp = CreateObject("Word.Application")
Set wordDoc = wordApp.Documents.Open("C:\TempPrint\wordTemplate.docx")
wordDoc.Fields.Update
'Open the Excel file
Set excelApp = CreateObject("Excel.Application")
Set excelWorkbook = excelApp.Workbooks.Open("C:\TempPrint\excel2.xlsx")
Set ws = excelWorkbook.Sheets(1)
'Remove all mail merge fields from the Word document
For Each fld In wordDoc.Fields
fld.Unlink
Next fld
'Merge pr colunas
'Substitute words with values from the checklist
'Loop through each search value in column A or each search value in row 1, depending on the option button clicked
If Upload.OptionButton1.value = True Then 'OptionButton1 is selected
For i = 1 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
searchValue = Trim(ws.Cells(i, 1).value)
replaceValue = CStr(ws.Cells(i, 2).value)
'Search for matches of the search value and replace them with the replace value
Set wordRange = wordDoc.Content
With wordRange.Find
.ClearFormatting
.Text = searchValue
.MatchWildcards = True
If IsArray(replaceValue) Then
.Replacement.Text = Join(replaceValue, ", ")
Else
.Replacement.Text = replaceValue
End If
.Execute Replace:=wdReplaceAll
End With
'Replace headers
For Each Section In wordDoc.Sections
For Each HeaderFooter In Section.Headers
Set wordRange = HeaderFooter.range
With wordRange.Find
.ClearFormatting
.Text = searchValue
.MatchWildcards = True
If IsArray(replaceValue) Then
.Replacement.Text = Join(replaceValue, ", ")
Else
.Replacement.Text = replaceValue
End If
.Execute Replace:=wdReplaceAll
End With
Next HeaderFooter
Next Section
Next i
End If
If Upload.OptionButton2.value = True Then 'OptionButton2 is selected
For i = 1 To ws.Cells(1, Columns.Count).End(xlToLeft).Column
searchValue = Trim(ws.Cells(1, i).value)
replaceValue = CStr(ws.Cells(2, i).value)
'Search for matches of the search value and replace them with the replace value
Set wordRange = wordDoc.Content
With wordRange.Find
.ClearFormatting
.Text = searchValue
.MatchWildcards = True
If IsArray(replaceValue) Then
.Replacement.Text = Join(replaceValue, ", ")
Else
.Replacement.Text = replaceValue
End If
.Execute Replace:=wdReplaceAll
End With
'Replace headers
For Each Section In wordDoc.Sections
For Each HeaderFooter In Section.Headers
Set wordRange = HeaderFooter.range
With wordRange.Find
.ClearFormatting
.Text = searchValue
.MatchWildcards = True
If IsArray(replaceValue) Then
.Replacement.Text = Join(replaceValue, ", ")
Else
.Replacement.Text = replaceValue
End If
.Execute Replace:=wdReplaceAll
End With
Next HeaderFooter
Next Section
Next i
End If
'Define words for gender
' Define the source and destination paths
Dim xlApp As Object
Dim xlWorkbook As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlWorkbook = xlApp.Workbooks.Open("C:\TempPrint\Setup.xlsx")
sourcePath = xlWorkbook.Sheets(1).range("C2").value
destPath = "C:\TempPrint\Mapping.xlsx"
' Check if the source file exists
If Not Dir(sourcePath) <> "" Then
MsgBox "Source file does not exist!"
Exit Sub
End If
' Copy the file to the destination path
FileCopy sourcePath, destPath
'Open the Excel file
Set excelAApp = CreateObject("Excel.Application")
Set excelWWorkbook = excelApp.Workbooks.Open("C:\TempPrint\Mapping.xlsx")
Set ms = excelWWorkbook.Sheets(1)
'Loop through each search value in column A or each search value in row 1, depending on the option button clicked
If SelectTemplate.OptionButton1.value = True Then 'OptionButton1 is selected
For i = 1 To ms.Cells(ms.Rows.Count, 1).End(xlUp).Row
searchValue = ms.Cells(i, 1).value
replaceValue = CStr(ms.Cells(i, 2).value)
'Search for matches of the search value and replace them with the replace value
Set wordRange = wordDoc.Content
With wordRange.Find
.ClearFormatting
.Text = searchValue
.MatchWildcards = True
If IsArray(replaceValue) Then
.Replacement.Text = Join(replaceValue, ", ")
Else
.Replacement.Text = replaceValue
End If
.Execute Replace:=wdReplaceAll
End With
Next i
ElseIf SelectTemplate.OptionButton2.value = True Then 'OptionButton2 is selected
For i = 1 To ms.Cells(ms.Rows.Count, 1).End(xlUp).Row
searchValue = ms.Cells(i, 1).value
replaceValue = CStr(ms.Cells(i, 3).value)
'Search for matches of the search value and replace them with the replace value
Set wordRange = wordDoc.Content
With wordRange.Find
.ClearFormatting
.Text = searchValue
.MatchWildcards = True
If IsArray(replaceValue) Then
.Replacement.Text = Join(replaceValue, ", ")
Else
.Replacement.Text = replaceValue
End If
.Execute Replace:=wdReplaceAll
End With
Next i
End If
'Replace the symbol with an empty string
wordApp.Selection.Find.Execute FindText:="»", ReplaceWith:="", _
Replace:=2, Forward:=True, Wrap:=wdFindContinue
'Replace the symbol with an empty string
wordApp.Selection.Find.Execute FindText:="«", ReplaceWith:="", _
Replace:=2, Forward:=True, Wrap:=wdFindContinue
'Loop through each section in the document
For Each wdSec In wordDoc.Sections
'Loop through each header in the section
For Each wdHF In wdSec.Headers
Set wdRng = wdHF.range
With wdRng.Find
.Text = "«"
.Replacement.Text = ""
.Wrap = 1 '1 = wdFindContinue
.Execute Replace:=2 '2 = wdReplaceAll
End With
Next wdHF
'Loop through each footer in the section
For Each wdHF In wdSec.Footers
Set wdRng = wdHF.range
With wdRng.Find
.Text = "«"
.Replacement.Text = ""
.Wrap = 1 '1 = wdFindContinue
.Execute Replace:=2 '2 = wdReplaceAll
End With
Next wdHF
Next wdSec
'Loop through each section in the document
For Each wdSec In wordDoc.Sections
'Loop through each header in the section
For Each wdHF In wdSec.Headers
Set wdRng = wdHF.range
With wdRng.Find
.Text = "»"
.Replacement.Text = ""
.Wrap = 1 '1 = wdFindContinue
.Execute Replace:=2 '2 = wdReplaceAll
End With
Next wdHF
'Loop through each footer in the section
For Each wdHF In wdSec.Footers
Set wdRng = wdHF.range
With wdRng.Find
.Text = "»"
.Replacement.Text = ""
.Wrap = 1 '1 = wdFindContinue
.Execute Replace:=2 '2 = wdReplaceAll
End With
Next wdHF
Next wdSec
wordDoc.Fields.Update
'Remove all mail merge fields from the Word document
For Each fld In wordDoc.Fields
fld.Unlink
Next fld
Dim ObjRng As Object
Dim NumberingOption As String
Dim ArticleWord As String
Dim ColonWord As String
Dim OrderOption As String
'Read values from cells D2 and F2
NumberingOption = xlWorkbook.Sheets(1).range("D2").value
ArticleWord = xlWorkbook.Sheets(1).range("E2").value
ColonWord = xlWorkbook.Sheets(1).range("F2").value
OrderOption = xlWorkbook.Sheets(1).range("G2").value
'Open the Word document
'Get the range of the document
Set ObjRng = wordDoc.Content
If NumberingOption = "Yes" And OrderOption = "After" Then
For k = 1 To ObjRng.Words.Count
If RTrim(ObjRng.Words(k)) = ArticleWord Then
Artcnt = Artcnt + 1
'Add the number to the word
ObjRng.Words(k).Text = ArticleWord & " " & CStr(Artcnt) & " " & ColonWord
End If
Next k
ElseIf NumberingOption = "Yes" And OrderOption = "Before" Then
For k = 1 To ObjRng.Words.Count
If RTrim(ObjRng.Words(k)) = ArticleWord Then
Artcnt = Artcnt + 1
'Add the number to the word
ObjRng.Words(k).Text = ArticleWord & " " & ColonWord & " " & CStr(Artcnt)
End If
Next k
End If
'Save the Word document in the selected format and path based on the selected option button
If Len(SelectTemplate.TextBox2.value) > 0 And Len(SelectTemplate.TextBox1.value) > 0 Then
filePath = SelectTemplate.TextBox2.value
fileName = SelectTemplate.TextBox1.value
If SelectTemplate.OptionButton7.value = True Then 'OptionButton7 is selected (save as Word file)
wordDoc.SaveAs2 fileName:=filePath & "\" & fileName & ".docx", FileFormat:=WdSaveFormat.wdFormatDocumentDefault
ElseIf SelectTemplate.OptionButton8.value = True Then 'OptionButton8 is selected (save as PDF file)
wordDoc.SaveAs2 fileName:=filePath & "\" & fileName & ".pdf", FileFormat:=wdFormatPDF
ElseIf SelectTemplate.OptionButton6.value = True Then 'OptionButton6 is selected (save as both Word and PDF file)
wordDoc.SaveAs2 fileName:=filePath & "\" & fileName & ".docx", FileFormat:=WdSaveFormat.wdFormatDocumentDefault
wordDoc.SaveAs2 fileName:=filePath & "\" & fileName & ".pdf", FileFormat:=wdFormatPDF
End If
End If
'Mapping
excelWWorkbook.Close False 'closes workbook without saving changes
excelAApp.Quit 'quits the Excel application
Set ms = Nothing 'release reference to worksheet
Set excelWWorkbook = Nothing 'release reference to workbook
Set excelAApp = Nothing 'release reference to Excel application
Kill "C:\TempPrint\Mapping.xlsx"
'Setup
xlWorkbook.Close False 'closes workbook without saving changes
xlApp.Quit 'quits the Excel application
Set xlWorkbook = Nothing 'release reference to workbook
Set xlApp = Nothing 'release reference to Excel application
'excel2
excelWorkbook.Close False 'closes workbook without saving changes
excelApp.Quit 'quits the Excel application
Set ws = Nothing 'release reference to worksheet
Set excelWorkbook = Nothing 'release reference to workbook
Set excelApp = Nothing 'release reference to Excel application
Kill "C:\TempPrint\excel2.xlsx"
'wordtemplate
wordDoc.Close False 'closes the document without saving changes
wordApp.Quit 'quits the Word application
Set wordDoc = Nothing 'release reference to document
Set wordApp = Nothing 'release reference to Word application
Kill "C:\TempPrint\wordTemplate.docx"
'Get the ending time
Dim endTime As Double
endTime = Timer
'Calculate the total time taken in minutes
Dim totalTime As Double
totalTime = Round((endTime - startTime) / 60)
'Display the time taken in a message box
MsgBox "Code took " & totalTime & " minutes to run.", vbInformation, "Time Taken"
End Sub
