How can i search for text and check the same text for underline in the word document.
Can anyone help me out??
Sub Underline()
Dim fnd As String
Dim n As Long
fnd = InputBox("Enter text to search" & vbCr & vbCr _
& "Click OK to search the entire workbook for all instances of the search text.")
Dim x As Integer
x = 0
Do While x = 0
With Selection.Find
.ClearFormatting
End With
If fnd = False Then
x = 1
Exit Do
End If
Selection.Find.Execute
If .Underline = False Then
Selection.Comments.Add Range:=Selection.Range, Text:="pls underline text"
Selection.Find.Execute
End If
Loop
End Sub
Is this what you are trying?
Sub Sample()
Dim c As Range
Dim fnd As String
fnd = InputBox("Enter text to search" & vbCr & vbCr _
& "Click OK to search the entire document for all instances of the search text.")
If fnd = "" Then Exit Sub
Set c = ActiveDocument.Content
c.Find.ClearFormatting
c.Find.Replacement.ClearFormatting
With c.Find
.Text = fnd
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
End With
c.Find.Execute
While c.Find.Found
If c.Font.Underline = wdUnderlineNone Then
c.Select
c.Comments.Add Range:=Selection.Range, Text:="pls underline text"
End If
c.Find.Execute
Wend
End Sub
comment the below line in code from Siddharth Rout
c.Comments.Add Range:=Selection.Range, Text:="pls underline text"
Related
Any help would be awesome. I have a macro that finds acronyms and applies a spell out of the acronym with the acronym in parenthesis. It is applying the spell out and acronym once but randomly. I need the macro to identify the first instance and apply the spell out only to that first instance. So if the first instance should look like this:
Be Right Back (BRB) some text BRB some text BRB
Right know it looks like this: BRB some text Be Right Back (BRB) some text BRB
The macro has the code " .Execute Replace:=wdReplaceOne" but it doesn't seem to be working.
Here's the code I am using:
Sub AcronymManager()
Application.ScreenUpdating = False
Dim FRDoc As Document, FRList As String, j As Long, StrExp As String, StrAcc As String
'Load the strings from the reference doc into a text string to be used as an array.
Set FRDoc = ThisDocument
'Alternative code to use a different document the reference doc:
'Set FRDoc = Documents.Open("C:\Users" & Environ("UserName") & "\Documents\AcronymList.doc")
If ActiveDocument = FRDoc Then
MsgBox "Error: Cannot process this document - it's the source document", vbCritical
Exit Sub
End If
FRList = FRDoc.Range.Text
If FRDoc <> ThisDocument Then FRDoc.Close wdDoNotSaveChanges
Set FRDoc = Nothing
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindContinue
'Process each word from the Check List. Tab-delimited strings are assumed, formatted as:
'Find text <Tab> Replace text
For j = 0 To UBound(Split(FRList, vbCr)) - 1
StrExp = Split(Split(FRList, vbCr)(j), vbTab)(0)
StrAcc = Split(Split(FRList, vbCr)(j), vbTab)(1)
.Text = StrExp
.Replacement.Text = StrAcc
.Execute Replace:=wdReplaceAll
.Text = "(" & StrAcc & ")"
.Execute Replace:=wdReplaceAll
.Text = StrAcc & "^w" & StrAcc
.Execute Replace:=wdReplaceAll
.Text = StrAcc
.Replacement.Text = StrExp & " (" & StrAcc & ")"
.Execute Replace:=wdReplaceOne
Next
End With
Application.ScreenUpdating = True
End Sub
I am looking the for the correct syntax to use a text function to find strings that contain underscores. I have a very large document that has numerous tables names with underscores. They are in the format abc_def or abc_def_ghi or abc_def_ghi_jkl etc.
I have tried various combinations and cannot get anything to work as I expect it to. Below is my latest iteration.
Sub ExtractTablesToNewDocument()
'=========================
'Macro created 2008 by Lene Fredborg, DocTools - www.thedoctools.com
'THIS MACRO IS COPYRIGHT. YOU ARE WELCOME TO USE THE MACRO BUT YOU MUST KEEP THE LINE ABOVE.
'YOU ARE NOT ALLOWED TO PUBLISH THE MACRO AS YOUR OWN, IN WHOLE OR IN PART.
'=========================
'The macro creates a new document,
'finds all words consisting of 3 or more uppercase letters
'in the active document and inserts the words
'in column 1 of a 3-column table in the new document
'Each acronym is added only once
'Use column 2 for definitions
'Page number of first occurrence is added by the macro in column 3
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract Acronyms to New Document"
'Show msg - stop if user does not click Yes
Msg = "This macro finds all words consisting of 3 or more " & _
"uppercase letters and extracts the words to a table " & _
"in a new document where you can add definitions." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
.Cell(1, 3).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<*>[_]<*>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close savechanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub
Try:
.Text = "[! ]#_[! ]{1,}"
This will find strings containing however many underscores there might be, including where those strings start or end with an underscore.
Try:
Sub AcronymLister()
Application.ScreenUpdating = False
Dim StrTmp As String, StrAcronyms As String, i As Long, j As Long, k As Long, Rng As Range, Tbl As Table
StrAcronyms = "Acronym" & vbTab & "Page" & vbCr
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "[! ^13^t^11]#_[! ^13^t^11]{1,}"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found = True
If InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0 Then
StrAcronyms = StrAcronyms & .Text & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbCr
End If
If Len(.Text) = 0 Then .End = .Paragraphs(1).Range.Next.Start
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
With .Range
Set Rng = .Characters.Last
With Rng
If .Characters.First.Previous <> vbCr Then .InsertAfter vbCr
.InsertAfter Chr(12)
.Collapse wdCollapseEnd
.Style = "Normal"
.Text = StrAcronyms
Set Tbl = .ConvertToTable(Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=2)
With Tbl
.Columns.AutoFit
.Rows(1).HeadingFormat = True
.Rows(1).Range.Style = "Strong"
.Rows.Alignment = wdAlignRowCenter
End With
.Collapse wdCollapseStart
End With
End With
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub
Note: The above code puts the acronym table at the end of the current document. I've modified the Find expression to exclude tabs, paragraph breaks & line breaks.
Sub AcronymLister()
Application.ScreenUpdating = False
Dim StrTmp As String, StrAcronyms As String, i As Long, j As Long, k As Long, Rng As Range, Tbl As Table
StrAcronyms = "Acronym" & vbTab & "Page" & vbCr
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "[! ^13^t^11]#_[! ^13^t^11]{1,}"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found = True
If InStr(.Text, "_") = 0 Then
If InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0 Then
StrAcronyms = StrAcronyms & .Text & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbCr
Else
.End = .Paragraphs(1).Range.Next.Start
End If
End If
If InStr(.Text, "_") > 0 Then
If InStr(1, StrAcronyms, .Text, vbBinaryCompare) = 0 Then
StrAcronyms = StrAcronyms & .Text & vbTab & .Information(wdActiveEndAdjustedPageNumber) & vbCr
Else
.End = .Paragraphs(1).Range.Next.Start
End If
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
With .Range
Set Rng = .Characters.Last
With Rng
If .Characters.First.Previous <> vbCr Then .InsertAfter vbCr
.InsertAfter Chr(12)
.Collapse wdCollapseEnd
.Style = "Normal"
.Text = StrAcronyms
Set Tbl = .ConvertToTable(Separator:=vbTab, NumRows:=.Paragraphs.Count, NumColumns:=2)
With Tbl
.Columns.AutoFit
.Rows(1).HeadingFormat = True
.Rows(1).Range.Style = "Strong"
.Rows.Alignment = wdAlignRowCenter
End With
.Collapse wdCollapseStart
End With
End With
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub
#macropod i added a loop to handle zero length strings and the code appears to be working. I know this is not the most efficient method, do you have any suggestions for improvement? Thank you again for walking me through this i really appreciate all your help and knowledge.
I have a working, however a slow method for searching through a document and search for a specific text: Issue "tab" A and then replace it with text but where A is referred to a customvariable. Has anyone done something similar?
Sub hsdkjgh()
Call replaceIssueNonVariable(ActiveDocument)
End Sub
Public Function SearchInStory(ByVal rngStory As word.Range, ByVal strSearch As String) As Boolean
SearchInStory = False
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.MatchCase = False
.MatchWildcards = True
.Execute
If .found Then
rngStory.Text = "Issue:" & vbTab & ";;;;;;"
Call SearchInStory2(rngStory, ";;;;;;")
SearchInStory = True
End If
End With
End Function
Public Function SearchInStory2(ByVal rngStory As word.Range, ByVal strSearch As String) As Boolean
SearchInStory2 = False
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.MatchCase = False
.MatchWildcards = True
.Execute
If .found Then
rngStory.Select
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldDocProperty, Text:="_DocumentIssue", PreserveFormatting:=True
SearchInStory2 = True
End If
End With
End Function
Sub replaceIssueNonVariable(doc As Document)
Dim temp As Variant
Dim pFindTxtArray(4) As String
Dim pReplaceTxtArray(4) As String
pReplaceTxt = "Issue:^t" ' { DOCPROPERTY _DocumentIssue ^92* MERGEFORMAT }"
ActiveWindow.View.ShowFieldCodes = True
exitRevision = False
For i = 65 To 90
pFindTxt = "Issue:^t^" & i
'Iterate through all story types in the current document
For Each rngStory In doc.StoryRanges
'Iterate through all linked stories
Do
If SearchInStory(rngStory, pFindTxt) Then
'rngStory.Select
'Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldDocProperty, Text:="_DocumentIssue", PreserveFormatting:=True
exitRevision = True
End If
On Error Resume Next
Select Case rngStory.StoryType
Case WdStoryType.wdEvenPagesHeaderStory, _
WdStoryType.wdPrimaryHeaderStory, _
WdStoryType.wdEvenPagesFooterStory, _
WdStoryType.wdPrimaryFooterStory, _
WdStoryType.wdFirstPageHeaderStory, _
WdStoryType.wdFirstPageFooterStory
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
If SearchInStory(rngStory, pFindTxt) Then
exitRevision = True
End If
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
If exitRevision Then
Call CustomProperties.createCustomDocumentProperty(doc, "_DocumentIssue", Chr(i))
Exit For
End If
Next i
' Refresh fields
doc.Fields.update
ActiveWindow.View.ShowFieldCodes = False
Exit Sub
'create the new variable
Call CustomProperties.createCustomDocumentProperty(doc, "_DocumentIssue", Right(pFindTxtArray, 1))
doesNotExist:
MsgBox "CustomVariable " & findText & " does not exist"
Exit Sub
Debug.Print findText & " variable has got this new name: " & replaceText
End Sub
How can I rename my customVariable in word? I have a Customvaraiable called "Document Number", but I would now like to rename it to _DocumentNumber"
I know I can create a new CustomVariable, delete the old one, but I am then struggling with how to update all the links in the document to the new one.
Edited code:
Sub test()
Dim A As word.Field
Dim FldUpd As String
Dim findText As String
Dim replaceText As String
findText = "Document Number"
replaceText = "_DocumentNumber"
ActiveWindow.View.ShowFieldCodes = False
If ActiveDocument.CustomDocumentProperties(findText).value = "" Then Exit Sub
For Each A In ActiveDocument.Fields
If A.result.Text = ActiveDocument.CustomDocumentProperties(findText).value Then
Call WordProperties.createCustomDocumentProperty(ActiveDocument.name, replaceText, ActiveDocument.CustomDocumentProperties(findText).value)
ActiveWindow.View.ShowFieldCodes = True
A.Select
'DOCPROPERTY "Document number" \* MERGEFORMAT
With Selection.Find
.Text = "DOCPROPERTY*" & findText
.Replacement.Text = "DOCPROPERTY " & replaceText
.Format = True
.MatchCase = False
.MatchWildcards = True
End With
tempBool = Selection.Find.Execute(replace:=wdReplaceAll)
' Refresh fields
ActiveDocument.Fields.update
ActiveWindow.View.ShowFieldCodes = False
If tempBool Then ActiveDocument.CustomDocumentProperties(findText).Delete
End If
Next
End Sub
Edited:
The problem is that the find method does not return true.
You are mixing up two things that must be separate.
First create the new doc property, using ActiveDocument.CustomDocumentProperties.Add
You do this only once, since the doc property exists only once.
Then you replace all existing references to the old doc property to the new one. Something like (excerpts from macro recorder)
' Show field source references (Alt+F9) so you can use Find&Replace
ActiveWindow.View.ShowFieldCodes = True
With Selection.Find
.Text = "DOCPROPERTY Document Number"
.Replacement.Text = "DOCPROPERTY _DocumentNumber"
.Format = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Refresh fields
ActiveDocument.Fields.Update
ActiveWindow.View.ShowFieldCodes = False
Then you can delete the old doc property.
Edit: to find and replace in all sections (including header & footer), see
Searching for Text in Header Section of A Word Document
Here is the working code, feel free to improve it:
Sub test()
Dim findText As String
Dim replaceText As String
Dim temp As Variant
findText = "Document Number"
replaceText = "_DocumentNumber"
On Error GoTo doesNotExist
temp = ActiveDocument.CustomDocumentProperties(findText).value
pFindTxt = "DOCPROPERTY*" & findText
pReplaceTxt = "DOCPROPERTY """ & replaceText
ActiveWindow.View.ShowFieldCodes = True
'create the new variable
Call WordProperties.createCustomDocumentProperty(ActiveDocument.name, replaceText, ActiveDocument.CustomDocumentProperties(findText).value)
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case rngStory.StoryType
Case WdStoryType.wdEvenPagesHeaderStory, _
WdStoryType.wdPrimaryHeaderStory, _
WdStoryType.wdEvenPagesFooterStory, _
WdStoryType.wdPrimaryFooterStory, _
WdStoryType.wdFirstPageHeaderStory, _
WdStoryType.wdFirstPageFooterStory
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SearchAndReplaceInStory oShp.TextFrame.TextRange, pFindTxt, pReplaceTxt
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
' Refresh fields
ActiveDocument.Fields.update
ActiveWindow.View.ShowFieldCodes = False
Exit Sub
doesNotExist:
MsgBox "CustomVariable " & findText & " does not exist"
Exit Sub
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngStory As word.Range, ByVal strSearch As String, ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.MatchCase = False
.MatchWildcards = True
.Execute replace:=wdReplaceAll
End With
End Sub
I've written a VBA Word Macro that read a .txt File, copy it and paste it in a Word document setting a new font.
All is working fine! Now I would like to highlight some specific lines with bold + italic font, but i cannot figure out a working solution.
The specific lines begins with a specific word (for example Simulation Nr.xxx) or they begin with some words but then they have a very long series of blank spaces (for example Turbine).
How can i solve the problem?
P.s.: here the working code that copy/paste the .txt file into a word document.
Sub ACTUS_Table_Converter()
Dim pName As String
Dim bDoc As Document
Dim AppPath, ThisPath As String
Dim Rng As Range
ThisPath = ActiveDocument.Path
pName = ActiveDocument.Name
With Dialogs(wdDialogFileOpen)
If .Display Then
If .Name <> "" Then
Set bDoc = Documents.Open(.Name)
AppPath = bDoc.Path
End If
Else
MsgBox "No file selected"
End If
End With
Call ReplaceAllxSymbolsWithySymbols
Call ChangeFormat
Selection.Copy
Windows(pName).Activate
Selection.Paste
Selection.Collapse
bDoc.Close savechanges:=False
End Sub
Sub ChangeFormat()
Selection.WholeStory
With Selection.Font
.Name = "Courier New"
.Size = 6
End With
End Sub
Sub ReplaceAllxSymbolsWithySymbols()
'Call the main "ReplaceAllSymbols" macro (below),
'and tell it which character code and font to search for, and which to replace with
Call ReplaceAllSymbols(FindChar:=ChrW(-141), FindFont:="(normal text)", _
ReplaceChar:=ChrW(179), ReplaceFont:="(normal text)")
Call ReplaceAllSymbols(FindChar:=ChrW(-142), FindFont:="(normal text)", _
ReplaceChar:=ChrW(178), ReplaceFont:="(normal text)")
Call ReplaceAllSymbols(FindChar:=ChrW(-144), FindFont:="(normal text)", _
ReplaceChar:=ChrW(176), ReplaceFont:="(normal text)")
Call ReplaceAllSymbols(FindChar:="°", FindFont:="(normal text)", _
ReplaceChar:="", ReplaceFont:="(normal text)")
End Sub
Sub ReplaceAllSymbols(FindChar As String, FindFont As String, _
ReplaceChar As String, ReplaceFont As String)
Dim FoundFont As String, OriginalRange As Range, strFound As Boolean
Application.ScreenUpdating = False
Set OriginalRange = Selection.Range
'start at beginning of document
ActiveDocument.Range(0, 0).Select
strFound = False
If ReplaceChar = "" Then
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindChar
.Replacement.Text = ReplaceChar
.Replacement.Font.Name = "Courier New"
.Replacement.Font.Size = 6
.MatchCase = True
End With
If Selection.Find.Execute Then
Selection.Delete Unit:=wdCharacter, Count:=2
Selection.TypeText ("°C")
End If
Else
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindChar
.Replacement.Text = ReplaceChar
.Replacement.Font.Name = "Courier New"
.Replacement.Font.Size = 6
.MatchCase = True
.Execute Replace:=wdReplaceAll
End With
End If
OriginalRange.Select
Set OriginalRange = Nothing
Application.ScreenUpdating = True
Selection.Collapse
End Sub
The following code should run over the document, looking for line starts with Simulation Nr. and replace the whole line font with bold and italic.
Sub ReplaceLinesStartWith()
Dim startingWord As String
'the string to search for
startingWord = "Simulation Nr."
Dim myRange As range
'Will change selection to the document start
Set myRange = ActiveDocument.range(ActiveDocument.range.Start, ActiveDocument.range.Start)
myRange.Select
While Selection.End < ActiveDocument.range.End
If Left(Selection.Text, Len(startingWord)) = startingWord Then
With Selection.Font
.Bold = True
.Italic = True
End With
End If
Selection.MoveDown Unit:=wdLine
Selection.Expand wdLine
Wend
End Sub
Note that I hardcoded the string to search for, you can set it as function argument instead.