I wrote a simple code in VBA for MS WORD,
in which I want to add dot at the end of each paragraph that has no dot.
The code is as follows:
Function FindParagraph(ByVal doc As Document, ByVal Npara As String) As Paragraph
Dim para As Paragraph
For Each para In doc.Paragraphs
If para.Range.ListFormat.ListString = Npara Then
Set FindParagraph = para
End If
Next para
End Function
Sub End_para_with_dot()
Dim doc As Document
Dim tb As table
Dim prange As Range
Dim srange As Range
Dim para As Paragraph
Dim spara As Paragraph
Dim epara As Paragraph
Dim txt As String
Set doc = ActiveDocument
Set spara = FindParagraph(doc, "1")
Set epara = FindParagraph(doc, "2")
Set srange = doc.Range(spara.Range.Start, epara.Range.Start) 'sets a specific range of paragraphs in doc
For Each para In srange.Paragraphs
Set prange = para.Range
With prange
If .Style <> "Nagłówek 1" Then
Debug.Print .Text
txt = Trim(.Text)
n = Len(txt)
last_c = Mid(txt, n - 1, 1)
If last_c <> "." Then
txt = Left(txt, n - 1) & "." & Chr(13)
Debug.Print txt
End If
.Text = txt '!!!SUPPOSED REASON FOR ERROR!!!
End If
End With
Next para
End Sub
Unfortunately, after I run this code an infinite loop is produced with the first found paragraph being print all the time.
I suppose that it is due to .Text = txt line. Earlier I made a reference to the range object in this statement Set prange = para.Range. But I do not understand why when I want to reassign the .Text property of this object then the infinite loop is produced.
I would be grateful for any tip.
I'm assuming you don't want to add a . when the paragraph ends with any of !.,:;?
Try a wildcard Find/Replace, where:
Find = ([!\!.,:;\?])(^13)
Replace = \1.\2
Or, as a macro:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "([!\!.,:;\?])(^13)"
.Replacement.Text = "\1.\2"
.Format = False
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
Related
I am trying to create a VBA code for word that will search for a specific colored square bracket and then search for the corresponding closing bracket of that color and delete all text between these 2 colored bracket.
The code will search for a green square opening bracket then search for the green closing bracket and delete everything in between which in this case will be "brown fox". I will then add update the code for the color of the red bracket and have it delete everything between the red bracket. I have found the following code from another question on this site and this does work 90% but i cant get it to search for the specific colored bracket.
I tried
.Format = True + .Font.Color = WdColorRed
but it doesnt pick it up. Any help is appreciated. Thanks
Sub FindSquareBracketPairs()
Dim rngFind As Word.Range
Dim sOpen As String, sClose As String
Dim sFindTerm As String
Dim bFound As Boolean, lPosOpen As Long
Set rngFind = ActiveDocument.Content
sOpen = "["
sClose = "]"
sFindTerm = "\[*\] "
With rngFind.Find
.ClearFormatting
.Text = "\[*\] "
.Forward = True
.Wrap = Word.WdFindWrap.wdFindStop
.MatchWildcards = True
bFound = .Execute
Do While bFound
lPosOpen = NumberOfCharInRange(rngFind, sOpen)
rngFind.Delete
rngFind.Collapse wdCollapseEnd
bFound = .Execute
Loop
End With
End Sub
'Checks whether there's more than one instance of searchTerm in the rng.Text
'For each instance above one, move the Start point of the range
'To the position of that instance until no more are "found".
'Since the Range is passed ByRef this will change the original
'range's position in the calling procedure.
Function NumberOfCharInRange(ByRef rng As Word.Range, _
ByRef searchTerm As String) As Long
Dim lCountChars As Long, lCharPos As Long
Dim s As String
s = rng.Text
Do
lCharPos = InStr(s, searchTerm)
If lCharPos > 1 Then
lCountChars = lCountChars + 1
rng.Start = rng.Start + lCharPos
End If
s = Mid(s, lCharPos + 1)
Loop Until lCharPos = 0
NumberOfCharInRange = lCountChars
End Function
You'll want to get the Color from the Font of the range. Then use this website to use decimal you get or transfer/convert to hex or rgb someway. There are also constants in VBA such as wdRed but, it's the word red whatever that is.
Sub FindSquareBracketPairs()
Dim rngFind As Range
Dim sOpen As String, sClose As String
Dim sFindTerm As String
Dim bFound As Boolean, lPosOpen As Long
Set rngFind = ActiveDocument.Range
sOpen = "["
sClose = "]"
sFindTerm = "\[*\] "
For Each rng In ActiveDocument.StoryRanges
For Each rngChar In rng.Characters
Dim fnt As Font
Set fnt = rngChar.Font
Dim clr As WdColor
clr = rngChar.Font.Color
Next
Next
With rngFind.Find
'.ClearFormatting
.Text = "\[*\] "
.Forward = True
.Wrap = Word.WdFindWrap.wdFindStop
.MatchWildcards = True
bFound = .Execute
Do While bFound
lPosOpen = NumberOfCharInRange(rngFind, sOpen)
'Check if the first and last brackets are whatever color is passed here.
If (IsSurroundedByColor(wdColorRed, rngFind.Characters.First, rngFind.Characters(rngFind.Characters.Count - 1))) Then
rngFind.Delete
End If
rngFind.Collapse wdCollapseEnd
bFound = .Execute
Loop
End With
End Sub
Function IsSurroundedByColor(ByRef chkingClr As WdColor, ByRef frstChr As Range, ByRef lstChr As Range) As Boolean
IsSurroundedByColor = (frstChr.Font.Color = chkingClr And lstChr.Font.Color = chkingClr)
End Function
I have a large number of documents which I need to pull out file name references from, spread out across large blocks of text and footnotes.
I currently have a word VBA code that I think should search for a string (for example "This_") and then the following # of characters, and then paste them into a waiting excel sheet. I am struggling to get it to search both the footnotes and the main body of text.
I've been using the code below, but my work at the moment is making it do something weird. It will find the string I am searching for, but then it will copy from the start of the document the number of times the string has been found -- not the string and its subsequent text.
Any help would be appreciated in modifying this, I believe the issue will be coming from the first half of the 'return data to array section.
Option Explicit
Option Base 1
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
If IsWindowsOS Then
Tgt = "C:\users\user\" & TgtFile ' Windows OS
Else
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
ActiveDocument.StoryRanges(wdFootnotesStory).Select
With Selection.Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.workbooks.Open(Tgt)
Set mySh = myWB.sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
Public Function IsWindowsOS() As Boolean
If Application.System.OperatingSystem Like "*Win*" Then
IsWindowsOS = True
Else
IsWindowsOS = False
End If
End Function
Your code is a little confused as there is an unholy mix of Selection and Range. It is good practice to avoid using Selection as it is very rarely necessary to select anything when working in VBA.
VBA also has compiler constants that can be used to detect, among other things, whether code is being run on a Mac. Not sure if the Mac constant still works reliably as I no longer have one to test on.
'Set parameters Change to your path and filename
TgtFile = "File.xlsx"
'This isn't necessary as there is a compiler constant that can be used to identify code is running on Mac
' If IsWindowsOS Then
' Tgt = "C:\users\user\" & TgtFile ' Windows OS
' Else
' Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
' End If
#If Mac Then
Tgt = "MacintoshHD:Users:" & TgtFile 'Mac OS
#Else
Tgt = "C:\users\user\" & TgtFile ' Windows OS
#End If
txt = InputBox("String to find")
Lgth = InputBox("Length of string to return")
Strt = Len(txt)
'Return data to array
'not necessary to select the story range
'ActiveDocument.StoryRanges(wdFootnotesStory).Select
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
With oRng
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.MatchCase = True
End With
While .Find.Execute
'a match has been found and oRng redefined to the range of the match
i = i + 1
.MoveEnd wdCharacter, Lgth
arr(i) = .Text
.Collapse wdCollapseEnd
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
For example, the following code returns both the found text and its page reference:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, StrFnd As String, StrOut As String
StrFnd = InputBox("String to find")
j = InputBox("String Length to find")
k = j - Len(StrFnd)
For i = 1 To k
StrFnd = StrFnd & "^?"
Next
With ActiveDocument
For i = 1 To 2 ' 1 = wdMainTextStory, 2 = wdFootnotesStory, 3 = wdEndnotesStory, etc.
With .StoryRanges(i)
With .Find
.ClearFormatting
.Text = StrFnd
.Forward = True
.Format = True
.MatchWildcards = False
.Wrap = wdFindStop
.Replacement.Text = ""
End With
Do While .Find.Execute = True
StrOut = StrOut & vbCr & .Text & vbTab
Select Case .StoryType
Case wdMainTextStory
StrOut = StrOut & .Information(wdActiveEndAdjustedPageNumber)
Case wdFootnotesStory
StrOut = StrOut & .Duplicate.Footnotes(1).Reference.Information(wdActiveEndAdjustedPageNumber)
End Select
Loop
End With
Next
End With
MsgBox StrOut
Application.ScreenUpdating = True
End Sub
This is an example of how to search multiple section of your document. Note that I'm using a Collection to gather up the items, so you don't have to keep increasing an array.
Option Explicit
Option Base 1
Sub test()
Dim allFound As Collection
Set allFound = TextFoundReport("This_", 10)
Dim entry As Variant
For Each entry In allFound
Dim partType As Long
Dim text As String
Dim tokens() As String
tokens = Split(entry, "|")
'--- here is where you copy to an Excel sheet
Debug.Print "Part type: " & tokens(0) & " - '" & tokens(1) & "'"
Next entry
End Sub
Private Function TextFoundReport(ByVal text As String, _
ByVal numberOfCharacters As Long) As Collection
Dim whatWeFound As Collection
Set whatWeFound = New Collection
'--- create a list of the document parts to search
Dim docParts As Variant
docParts = Array(wdMainTextStory, wdFootnotesStory, wdEndnotesStory, wdCommentsStory)
Dim foundRng As Range
Dim docPart As Variant
For Each docPart In docParts
ActiveDocument.StoryRanges(docPart).Select
'--- find all occurences in this part and add it to the collection
' the Item in the collection is the story type and the found text
With Selection.Find
.ClearFormatting
.Forward = True
.text = text
.MatchCase = True
.Execute
Do While .found
Set foundRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Len(text), _
End:=Selection.Range.End + numberOfCharacters)
whatWeFound.Add CLng(docPart) & "|" & foundRng.text
foundRng.Start = foundRng.End
.Execute
Loop
End With
Next docPart
Set TextFoundReport = whatWeFound
End Function
Hi the following code extracts all instances of bold text from the active Word document and copies it to a newly created Word document.
Can anyone please help me to adjust the code to perform the same task on all open Word documents into the newly created Word document.
Any help is very much appreciated.
Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThisDoc = ActiveDocument
Set r = ThisDoc.Range
Set ThatDoc = Documents.Add
With r
With .Find
.Text = ""
.Format = True
.Font.Bold = True
End With
Do While .Find.Execute(Forward:=True) = True
'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
If r.Bold Then
ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
ThatDoc.Range.InsertParagraphAfter
.Collapse 0
End If
Loop
End With
cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub
You can use the Documents-collection which returns all open documents:
Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThatDoc = Documents.Add
'iterate over all open word documents
'For Each ThisDoc In Application.Documents
'handle documents in the order they were opened
'reverse order of documents collection
'loop until second to last as last one is ThatDoc
Dim i As Long
Dim FileNames As String, fFound As Boolean
Dim fWritten As Boolean
For i = Application.Documents.Count To 2 Step -1
Set ThisDoc = Application.Documents(i)
'Don't check document where the code runs
If Not ThisDoc Is ThisDocument Then
Set r = ThisDoc.Range
With r
With .Find
.Text = ""
.Format = True
.Font.Bold = True
End With
Do While .Find.Execute(Forward:=True) = True
'<-- remove this part if not needed
'add filename if the first bold range
If fWritten = False Then
ThatDoc.Content.InsertAfter vbCrLf & vbCrLf & ThisDoc.Name & vbCrLf
End If
'remove this part if not needed -->
fWritten = True
'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
If r.Bold Then
ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
ThatDoc.Range.InsertParagraphAfter
.Collapse 0
End If
Loop
End With
'add filename to list only if bold has been found
If fWritten = True Then
FileNames = FileNames & vbCrLf & ThisDoc.Name
fWritten = False
End If
End If
Next
'Add list of filenames to the end of ThatDoc
With ThatDoc.Content
.InsertParagraphAfter
.InsertAfter FileNames
End With
cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub
I am very close with achieving this task. The following vba code does copy the text to a new Word document. But I would like the text in the new document to maintain the highlighted colour it was in the original document.
I would be most grateful for assistance.
Sub CopyHighlightsToOtherDoc()
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThisDoc = ActiveDocument
Set r = ThisDoc.Range
Set ThatDoc = Documents.Add
With r.Find
.Text = ""
.Highlight = True
Do While .Execute(Forward:=True) = True
ThatDoc.Range.InsertAfter r.Text & vbCrLf
r.Collapse 0
Loop
End With
End Sub
Use the Range.FormattedText property to get text and formatting.
The syntax is ThisRange.FormattedText = ThatRange.FormattedText
EDIT:
Sub CopyHighlightsToOtherDoc()
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThisDoc = ActiveDocument
Set r = ThisDoc.Range
Set ThatDoc = Documents.Add
With r
With .Find
.Text = ""
.Highlight = True
End With
Do While .Find.Execute(Forward:=True) = True
ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
ThatDoc.Range.InsertParagraphAfter
.Collapse 0
Loop
End With
End Sub
I have a macro that find some properties of the word paragraphs. I need to find '4 Lines or more' paragraphs by using the macro.
I've try this code:
If oPar.LineCount = LineCount + 4 Then
See below for entire code:
Sub CheckKeepLinesTogether()
Application.ScreenUpdating = False
Const message As String = "Check Keep Lines Together"
Dim oPar As Paragraph
Dim oRng As Word.Range
Dim LineCount As Long
For Each oPar In ActiveDocument.Paragraphs
Set oRng = oPar.Range
With oRng
With .Find
.ClearFormatting
.Text = "^13"
.Execute
End With
Set oRng = oPar.Range
If oPar.KeepTogether = False Then
If oPar.LineCount = LineCount + 4 Then
.Select
Selection.Comments.Add Range:=Selection.Range
Selection.TypeText Text:=message
Set oRng = Nothing
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub
Replace the faulty line with the uncommented code :
'If oPar.LineCount = LineCount + 4 Then
If oPar.Range.ComputeStatistics(wdStatisticLines) >= 4 Then
By the way, you don't need to set Set oRng = oPar.Range twice.
Not tested
Sub CheckKeepLinesTogether()
Application.ScreenUpdating = False
Const message As String = "Check Keep Lines Together"
Dim oPar As Paragraph
Dim oRng As Word.Range
Dim LineCount As Long
For Each oPar In ActiveDocument.Paragraphs
Set oRng = oPar.Range
With oRng
With .Find
.ClearFormatting
.Text = "^13"
.Execute
End With
If oPar.KeepTogether = False Then
If oPar.Range.ComputeStatistics(wdStatisticLines) >= 4 Then
Set oRng = oPar.Range
oRng.Comments.Add Range:=oRng
oRng.TypeText Text:=message
Set oRng = Nothing
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub