While insertion point on any word can be selected whole word but without "()". How can select with "()"
Example text : (3)
Selection.Expand unit:=wdWord
str = Selection
MsgBox str ' shows only "3" not "(3)"
I just add the below code to solve;
Dim str As String
With Selection.Find
.ClearFormatting
.Text = "("
.Forward = False
.MatchWildcards = False
.Wrap = wdFindStop
.Execute
End With
Selection.Extend
With Selection.Find
.Text = ")"
.Forward = True
.Execute
.Text = ""
End With
str = Selection
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.
I have a transliteration function (from cyrillic to latin). I will use this function in a unviersal subroutine (with text of any lenght). This sub must to copy the source text, transliterate (from cyrillic to latin) and paste it below without any formatting changes and without using selection. The next step is reverse transliteration (again copy and paste below). There must be 3 textes in the final. I kinda know how to realize it, but i don't know what i should use instead of selection.
*
P.S. i tried use For Each word In ActiveDocument.Range.Words but it works bad with reverse transliteration (exactly that. without it, the function works perfectly in debugging)
P.P.S. sorry for mistakes in the text, i'm not a native speaker
Since you haven't posted any actual transliteration code, I'll leave you to add the cyrillic and latin character sets to the code below:
Sub Transliterate()
Application.ScreenUpdating = False
Dim p As Long, i As Long, StrLng1, StrLng2
'Insert the character codes for the cyrillic characters here
StrLng1 = Array(ChrW(&H430), ChrW(&H431), ChrW(&H432))
'Insert the corresponding latin characters here
StrLng2 = Array("a", "b", "c")
With ActiveDocument.Range
Do While .Characters.Last.Previous = vbCr
.Characters.Last.Previous.Delete
Loop
.InsertAfter vbCr
'Duplicate Content
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindContinue
.MatchWildcards = True
.Text = "^13"
.Replacement.Text = "^l"
.Execute Replace:=wdReplaceAll
.Font.Bold = True
.Text = "[!^l]#^l"
.Replacement.Text = "^p^&"
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Text = "^l^13"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Execute Replace:=wdReplaceAll
.Text = "[!^13]#^13"
.Replacement.Text = "^&^&^p"
.Execute Replace:=wdReplaceAll
End With
.Characters.Last.Previous.Delete
.Characters.First.Delete
'Loop through duplicated paragraphs
For p = .Paragraphs.Count - 1 To 2 Step -3
With .Paragraphs(p).Range
.Font.Italic = True
'Transliterate paragraph
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = False
.MatchCase = True
.Font.Bold = False
For i = 0 To UBound(StrLng1)
.Text = StrLng1(i)
.Replacement.Text = StrLng2(i)
.Execute Replace:=wdReplaceAll
Next
End With
'Duplicate translated paragraph
.Characters.Last.Next.FormattedText = .FormattedText
End With
Next
.Characters.Last.Previous.Delete
'Loop through duplicated paragraphs
For p = .Paragraphs.Count To 3 Step -3
With .Paragraphs(p).Range
.Font.Underline = wdUnderlineSingle
'Reverse Transliterate paragraph
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchWildcards = False
.Font.Bold = False
.MatchCase = True
For i = 0 To UBound(StrLng1)
.Text = StrLng2(i)
.Replacement.Text = StrLng1(i)
.Execute Replace:=wdReplaceAll
Next
End With
End With
Next
End With
Application.ScreenUpdating = True
End Sub
I have a Find and Replace macro that adds a space between the end of one sentence and the beginning of another when missing. This sometimes happens when I move sentences around in word.
I notice that if the cursor is to either side of the punctuation mark, the macro can’t see the Find pattern and doesn’t fix it. I assume it’s because Find and Replace starts searching from the cursor position. Is there a way to tweak the code so it finds them too?
I know I could just tell the macro to start from the beginning, but I would much rather it left the cursor in its current position, especially if I run it near the end of a long document.
Sub AddOneSpaceBetweenSentences()
' AddOneSpaceBetweenSentences Macro
'
With Selection.Find
.Forward = True
.Text = "(?)([.\?\!])([A-Z])"
.ClearFormatting
.Replacement.Text = "\1\2 \3" 'there is a space between \2 and \3
.MatchWildcards = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub
Better still:
Sub AddOneSpaceBetweenSentences()
Application.ScreenUpdating = False
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.MatchWildcards = True
.Wrap = wdFindContinue
.Text = "([.\?\!])([A-Z])"
.Replacement.Text = "\1 \2"
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub
The most reliable way is to use Range objects instead of Selection. When working with a Range the selection in the document doesn't change.
Sub AddOneSpaceBetweenSentences()
' AddOneSpaceBetweenSentences Macro
'
Dim rng as Word.Range
Set rng = ActiveDocument.Content
With rng.Find
.Forward = True
.Text = "(?)([.\?\!])([A-Z])"
.ClearFormatting
.Replacement.Text = "\1\2 \3" 'there is a space between \2 and \3
.MatchWildcards = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub
Is it really necessary to have a character before the end signs . or ? or !
If not, just replace "([.\?\!])([A-Z])" by "\1 \2"
Simple attempt: Just extend the selection by 2 characters to the left.
If cursor is on the first two characters of the documents, you would get an error. To prevent that and to prevent counting of characters, I just used Selection.Start > 10
If Selection.Start > 10 Then
Selection.Previous(Unit:=wdCharacter, Count:=2).Select
End If
... or do it a little more complicated:
Sub AddOneSpaceBetweenSentences()
Dim SearchText As String
Dim ReplaceText As String
' extend selection by 1 character
If Selection.Start > 0 Then
Selection.Previous(Unit:=wdCharacter, Count:=1).Select
End If
Selection.Collapse
' if selection begins directly before end of sentence (.?!)
' adapt search & replace pattern
If InStr(1, ".?!", Selection.Characters(1), vbBinaryCompare) > 0 Then
SearchText = "([.\?\!])([A-Z])"
ReplaceText = "\1 \2"
Else
SearchText = "(?)([.\?\!])([A-Z])"
ReplaceText = "\1\2 \3"
End If
With Selection.Find
.Forward = True
.text = SearchText
.ClearFormatting
.Replacement.text = ReplaceText
.MatchWildcards = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub
I am trying to insert fields within the headings in a Word document, not before or after them. This is to prepare Word files for import to Madcap Flare which allows file names to be specified within a private Word field. The following code doesn't work because the field is appended before the start of the heading, it needs to be embedded within it. How can I do this.
Sub prepareDocForImport()
Dim headingText As String '
With Selection.Find
.ClearFormatting
.Wrap = wdFindContinue
.Forward = True
.Format = True
.MatchWildcards = False
.Text = ""
.Style = ActiveDocument.Styles("Heading 1 ")
.Execute
While .Found
headingText = Selection.Range.Text
headingText = Replace(headingText , " ", "_")
headingText = LCase(headingText )
Selection.Collapse Direction:=wdCollapseStart
Set myField = ActiveDocument.Fields.Add(Range:=Selection.Range, Type:=wdFieldEmpty, Text:="PRIVATE:MADCAP:FILENAME<" & headingText & ">")
.Execute
Wend
End With
End Sub
Try moving the cursor one character into the header word.
I also added a line for ensuring that the search starts at the beginning of the document.
Sub prepareDocForImport()
Dim headingText As String
Dim myfield As Field
'Moving to beginning of doc in case a different starting point is selected
Selection.HomeKey wdStory
With Selection.Find
.ClearFormatting
.Wrap = wdFindContinue
.Forward = True
.Format = True
.MatchWildcards = False
.Text = ""
.Style = ActiveDocument.Styles("Heading 1 ")
.Execute
While .Found
headingText = Selection.Range.Text
headingText = Replace(headingText, " ", "_")
headingText = LCase(headingText)
Selection.Collapse Direction:=wdCollapseStart
'Move seleection one character into the header text
Selection.MoveRight Count:=1
Set myfield = ActiveDocument.Fields.Add(Range:=Selection.Range, _
Type:=wdFieldEmpty, _
Text:="PRIVATE:MADCAP:FILENAME<" & headingText & ">", _
PreserveFormatting:=True)
.Execute
Wend
End With
End Sub
I am trying to use a Word Macro to select all text with the style "Number_List" and call the .ConvertNumbersToText function on it. I am having trouble only finding the list or that specific style.
Dim selBkUp As Range
Set selBkUp = ActiveDocument.Range(ActiveDocument.Range.Start, ActiveDocument.Range.End)
With ActiveDocument.Range.Find
.Style = ActiveDocument.Styles("Number_List")
.Forward = True
.Wrap = wdFindContinue
Dim SearchSuccessful As Boolean
SearchSuccessful = .Execute
If SearchSuccessful Then
selBkUp.Select
Selection.Range.ListFormat.ConvertNumbersToText
Else
' code
End If
End With
I select the entire document and covert all of the lists numbers to text, but I am trying to only select ones with that specific style or avoid the other 5 styles that may or may not be present. Any help would be appreciated!
The following code will search for one style and, if found, will convert to another style. Below this code is another subroutine that will list all styles found in a document.
' From http://forums.codeguru.com/showthread.php?448185-Macro-to-Change-Styles-in-Word
' This code will search for a specified Style and convert that to another Style
Sub FindReplaceStyle()
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Style = "Normal" ' Look for 'Normal'
'.Text = ""
.Replacement.Style = "Heading 1" ' Change to 'Heading 1'
' .Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While Selection.Find.Execute()
If Selection.Start = Selection.Paragraphs.First.Range.Start Then
Selection.Style = "Heading 1"
End If
Selection.Collapse wdCollapseEnd
Loop
End Sub
The code below will produce a list of all styles found in a document.
Also, I get an error trying to use your "Number_List"
' Following code from: http://www.vbaexpress.com/forum/showthread.php?41125-How-to-get-all-the-applied-Paragraph-Styles-of-a-document
Sub GetActiveStyles()
Application.ScreenUpdating = False
Dim RngStory As Range, oSty As Style, StrType As String, StrStyles As String
With ActiveDocument
For Each oSty In .Styles
For Each RngStory In .StoryRanges
With RngStory.Find
.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Style = oSty.NameLocal
.Forward = True
.Wrap = wdFindStop
.Format = True
.Execute
If .Found Then
Select Case oSty.Type
Case wdStyleTypeCharacter: StrType = "Character"
Case wdStyleTypeList: StrType = "list"
Case wdStyleTypeParagraph: StrType = "Paragraph"
Case wdStyleTypeTable: StrType = "Table"
End Select
StrStyles = StrStyles & oSty.NameLocal & " (" & StrType & ")" & vbCr
Exit For
End If
End With
Next RngStory
Next oSty
End With
Debug.Print StrStyles
'MsgBox StrStyles
Application.ScreenUpdating = True
End Sub