I want to delete section break or page break at current page.but thes vba code does not work.how to modfiy it?
Sub Del_sectionbreakORpagebreak()
Selection.Bookmarks("\page").Range.Select 'select current page
With Selection.Find
.ClearFormatting
.Execute FindText:="^b", Format:=True 'find section break
fnd = .Found
End With
If fnd = True Then
With Selection.Find
.ClearFormatting
.Text = "^b"
.Replacement.Text = " "
.Forward = True
.Execute Replace:=wdReplaceOne
End With
Else
With Selection.Find
.Text = Chr(12)
.Replacement.Text = ""
.Forward = True
.Execute Replace:=wdReplaceOne
End With
End If
End Sub
Sub Del_sectionbreak()
Selection.Bookmarks("\page").Range.Select
With Selection.Find
.ClearFormatting
.Execute FindText:="^b", Format:=True
fnd = .Found
End With
If fnd = True Then
Selection.Delete
Else
With Selection.Find
.Text = Chr(12)
.Replacement.Text = vbNullString
.Forward = True
.Execute Replace:=wdReplaceOne
End With
End If
End Sub
the code fuction is delete sectionbreak or pagebreak in current page
You can't delete an automatic page break. For other page/section breaks:
Sub Demo()
With Selection.Bookmarks("\page").Range.Characters.Last
If .Previous.Text = Chr(12) Then .Previous.Text = vbNullString
If .Text = Chr(12) Then .Text = vbNullString
End With
End Sub
Related
I have some faulty paragraphs, which are causing my other macros to not work properly.
They are usually heading style 2, style 3
Empty (not sure)
before OR after table (not sure)
surrounded by dotted line
causes the heading and next table to merged together (not sure)
I tried to replace/removed those with the following macro:
Sub HeadingParaBug()
Dim H As Range
Set H = ActiveDocument.Range
LS = Application.International(wdListSeparator)
With H.Find
.Text = "^p "
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = " ^p"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "^p ^p"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
.Text = "^13{2" & LS & "}"
.Replacement.Text = "^p"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
.Text = ""
.Style = wdStyleHeading2
.MatchWildcards = False
Do While .Execute
If H.Text <> vbCr Then
H.Collapse 0
H.Select
H.InsertParagraph
H.Delete
End If
H.Collapse 0
Loop
End With
Set H = ActiveDocument.Range
With H.Find
.Style = wdStyleHeading3
Do While .Execute
If H.Text <> vbCr Then
H.Collapse 0
H.Select
H.InsertParagraph
H.Delete
End If
H.Collapse 0
Loop
End With
End Sub
But somehow, it do not completely removed/replace the faulty paragraph marks. The above macro finds those paragraphs, add new and then remove it. which eventually removed the dotted line.
Can anybody explain this phenomena? what is the right ways to remove/replace those paragraphs. please download and see test file with error on page 7
Update: Even I tried with the following code but it did nothing (on MacOS Video). I think it is not finding the hidden paragraphs:
Sub HidNempty()
Dim H As Range
Set H = ActiveDocument.Range
With H.Find
.Text = "^p "
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = " ^p"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "^p ^p"
.Replacement.Text = "^p^p"
.Execute Replace:=wdReplaceAll
.Text = "^p"
Do While .Execute
If H.Font.Hidden = True Then
H.Font.Hidden = False
If Len(Trim(H.Paragraphs(1).Range.Text)) = 1 Then
H.Delete
End If
End If
Loop
End With
End Sub
To unhide all document paragraphs, please try the next piece of code:
Sub UnHideParagraphs()
Dim para As Paragraph
For Each para In ActiveDocument.Paragraphs
If para.Range.Font.Hidden Then
para.Range.Font.Hidden = False
End If
Next para
End Sub
It should work even if only part of the paragraph range is hidden...
Find/Replace won't delete duplicate paragraph breaks before a table, between tables, or after a table. Try:
Sub Demo()
Application.ScreenUpdating = False
Dim LS As String, Tbl As Table, bHid As Boolean
LS = Application.International(wdListSeparator)
bHid = ActiveWindow.View.ShowHiddenText
ActiveWindow.View.ShowHiddenText = True
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = True
.Replacement.Font.Hidden = False
.Wrap = wdFindContinue
.MatchWildcards = False
.Text = "^p^w"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "^w^p"
.Execute Replace:=wdReplaceAll
.MatchWildcards = True
.Text = "^13{2" & LS & "}"
.Execute Replace:=wdReplaceAll
.Wrap = wdFindStop
End With
Do While .Find.Execute = True
With .Duplicate
.Font.Hidden = False
.Start = .Start + 1
.Text = vbNullString
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
For Each Tbl In ActiveDocument.Range.Tables
With Tbl.Range
Do While .Characters.First.Previous.Previous = vbCr
.Characters.First.Previous.Previous = vbNullString
Loop
.Characters.First.Previous.Font.Hidden = False
Do While .Characters.Last.Next = vbCr
If .Characters.Last.Next.End = ActiveDocument.Range.End Then Exit Do
If .Characters.Last.Next.Next.Information(wdWithInTable) = True Then Exit Do
.Characters.Last.Next = vbNullString
Loop
.Characters.Last.Next.Font.Hidden = False
End With
Next
ActiveWindow.View.ShowHiddenText = bHid
Application.ScreenUpdating = True
End Sub
You will observe various lines in the code that apply .Font.Hidden = False. Depending on what you're trying to achieve visually, you may or may not want those.
My goal is to highlight text from one open parenthesis to the next open parenthesis, if there is no closed parenthesis between them.
Sub HighlightNestedParentheses()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Highlight = True
Options.DefaultHighlightColorIndex = wdGray50
With Selection.Find
.Text = "\([!\)]#\("
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
The macro above works when the Word file contains the following text:
text (text (text
However, there is an infinite loop when the document contains a single open parenthesis:
text (text
I prefer to not highlight any text in this second case.
Try:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "\(*\)"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
End With
Do While .Find.Execute
With .Duplicate
Set Rng = .Characters.Last
Do While InStr(2, .Text, "(", vbTextCompare) > 0
.MoveEndUntil ")", wdForward
.End = .End + 1
.Start = .Start + 1
.MoveStartUntil "(", wdForward
Set Rng = .Characters.Last
Loop
End With
.End = Rng.End
.HighlightColorIndex = wdGray50
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
For your revised description:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
Set Rng = .Duplicate
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "("
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindStop
.Format = False
.MatchWildcards = False
End With
Do While .Find.Execute
Rng.Start = .Start + 1
With Rng
If InStr(.Text, ")") = 0 Then
.HighlightColorIndex = wdBrightGreen
Else
.MoveEndUntil ")", wdBackward
If InStr(.Text, "(") = 0 Then
.MoveEndUntil "(", wdBackward
.HighlightColorIndex = wdBrightGreen
End If
End If
End With
.Collapse wdCollapseStart
Loop
End With
Application.ScreenUpdating = True
End Sub
Thanks in advance for any reply.
I am working on presentation of some reports. The periodical reports are imported from a different software into Word template. For all tables and for each row I would like to change the color of the negative numbers in column 14 only if there is a certain text in column 3.
Unfortunately I have to use a Word template to do this. It seems that a macro is my only option so I have tried to Frankenstein something from different macros I found online:
Dim varColumn As Column
Dim clColumn As Column
Dim cCell As Variant
Set clColumn = Selection.Columns(3)
Set varColumn = Selection.Columns(14)
With clColumn
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.text = "value"
.Replacement.text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .Information(wdWithInTable) = True Then
Selection.MoveRight Unit:=wdCell, Count:=11
End If
If cCell < 0 Then
Selection.Font.color = wdColorRed
End If
Loop
End With
End Sub
I think the macro needs lines to repeat the search. See the two lines added before Loop.
With Selection
.HomeKey Unit:=wdStory 'Starts at the beginning, to search all tables.
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "value"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .Information(wdWithInTable) = True And _
.Cells(1).ColumnIndex = 3 Then 'Confirms it's in the 3rd column.
.MoveRight Unit:=wdCell, Count:=11
End If
If .Range < 0 Then
.Font.Color = wdColorRed
End If
.Collapse wdCollapseEnd 'Collapses the selection to no characters.
.Find.Execute 'Searches again from the current selection point.
Loop
End With
Try:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "-[0-9][0-9,.]{1,}"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found = True
If .Information(wdWithInTable) = True Then
If .Cells(1).ColumnIndex = 14 Then
If Split(.Rows(1).Cells(3).Range.Text, vbCr)(0) = "specified text" Then
.Font.ColorIndex = wdRed
End If
End If
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
If the table might have vertically-merged cells, change:
If Split(.Rows(1).Cells(3).Range.Text, vbCr)(0) = "specified text" Then
to:
If Split(.Tables(1).Cell(.Cells(1).RowIndex, 3).Range.Text, vbCr)(0) = "specified text" Then
I have a VBA macro(Word2010) script to highlight all the text in italics. But when executed in large file say a document with more than 10 pages the Word get crashed.
I have used the below code for this purpose.
Sub Italics_Highlight()
'
' test_italics_highlight_ Macro
'
'
Application.ScreenUpdating = False
Dim myString As Word.Range
Set myString = ActiveDocument.Content
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
While .Execute
myString.HighlightColorIndex = wdTurquoise
myString.Collapse wdCollapseEnd
Wend
End With
MsgBox "Thank you!"
End Sub
Could you please help to overcome this. Thanks for your help in advance.
Your error description looks like your code is running forever and doesn't finish.
You might want to add a DoEvents inside your While loop to keep Word responsive while running the code.
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
While .Execute
DoEvents 'keeps Word responsive
myString.HighlightColorIndex = wdTurquoise
myString.Collapse wdCollapseEnd
Wend
End With
I'm not sure if your code will ever stop. The loop might not stop at the end of the document but start again from beginning, and therefore always find something italic again and again, looping forever.
So you might need to set the .Wrap = wdFindStop to stop at the end of the document.
See Find.Wrap Property (Word).
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
.Wrap = wdFindStop 'stop at the end of the document
While .Execute
DoEvents 'keeps Word responsive
myString.HighlightColorIndex = wdTurquoise
myString.Collapse wdCollapseEnd
Wend
End With
You don't need to stop at each "found" and apply highlighting. You can do it as part of a Find/Replace:
Sub testInfiniteLoop()
Dim myString As word.Range
Set myString = ActiveDocument.content
Options.DefaultHighlightColorIndex = wdTurquoise
With myString.Find
.ClearFormatting
.Text = ""
.Font.Italic = True
.Replacement.Text = ""
.Replacement.Highlight = wdTurquoise
.wrap = wdFindStop 'stop at the end of the document
.Execute Replace:=wdReplaceAll
End With
End Sub
The following code not only highlights but also restores whatever highlight settings were previously in force:
Sub Italics_Highlight()
Application.ScreenUpdating = False
Dim i As Long: i = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdTurquoise
With ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = "^&"
.Replacement.Highlight = True
.Format = True
.Font.Italic = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Options.DefaultHighlightColorIndex = i
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
As you can see, you also don't need:
Dim myString As Word.Range
Set myString = ActiveDocument.Content
Sub FindandReplace()
Dim wrd As Word.Application
Set wrd = CreateObject("word.application")
wrd.Visible = True
AppActivate wrd.Name
FName = Dir("C:\Users\user\Desktop\folderb\*.doc")
Do While (FName <> "")
With wrd
.Documents.Open ("C:\Users\user\Desktop\folderb\" & FName)
If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
.ActiveWindow.View.Type = wdPrintView
End If
With Selection.Find
.Text = "Day 10"
.Replacement.Text = "Day 11"
.Execute Replace:=wdReplaceAll, Forward:=True, _
Wrap:=wdFindContinue
End With
With Selection.Find
.Text = "delta"
.Replacement.Text = "alpha"
.Execute Replace:=wdReplaceAll, Forward:=True, _
Wrap:=wdFindContinue
End With
With Selection.Find
.Text = "5.4.1"
.Replacement.Text = "5.6.0"
.Execute Replace:=wdReplaceAll, Forward:=True, _
Wrap:=wdFindContinue
End With
.ActiveDocument.Save
.ActiveDocument.Close
End With
FName = Dir
Loop
Set wrd = Nothing
End Sub
I am trying to find and replace texts in ten different word documents contained in "folderb"
But the problem is once i run this macro the documents open one by one, gets saved and exit.
The find and replace job is not being done!
Please tell me where have i gone wrong in the above code.
Any help would be sincerely appreciated.
Tried and tested
Sub LoopDirectory()
Dim vDirectory As String
Dim oDoc As Document
vDirectory = "D:\test\"
vFile = Dir(vDirectory & "*.docx")
Do While vFile <> ""
Set oDoc = Documents.Open(FileName:=vDirectory & vFile)
With oDoc.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
.Text = "Day 10"
.Replacement.Text = "Day 11"
.Execute Replace:=wdReplaceAll
.Text = "delta"
.Replacement.Text = "alpha"
.Execute Replace:=wdReplaceAll
.Text = "5.4.1"
.Replacement.Text = "5.6.0"
.Execute Replace:=wdReplaceAll
End With
oDoc.Close SaveChanges:=True
vFile = Dir
Loop
End Sub
I think that you are basically missing the part where you need to select all the text before you can replace content.
So after opening up the file before the first selection.find you need to select all the text in that document.
In your case it would be
.Documents.Open ("C:\Users\user\Desktop\folderb\" & FName)
If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
.ActiveWindow.View.Type = wdPrintView
End If
ActiveDocument.Range(0, 0).Select
Selection.WholeStory
With Selection.Find
.Text = "Day 10"
.Replacement.Text = "Day 11"
.Execute Replace:=wdReplaceAll, Forward:=True, _
Wrap:=wdFindContinue
End With