I need to copy a word always begining with exact string "p1" and copy that word to a table in another document. Then copy a sentence always between exact strings and copy that sentence to the same table.
let me explain with an example. Here are few paragraphs of text I need to copy from:
variable labels p1consid 'SDQ: Considerate (Parent1)'.
variable labels p1restles 'SDQ: Restless (Parent1)'.
variable labels p1somatic 'SDQ: Headache, stomach-ache (Parent1)'.
So, "p1consid" should go to a column 1 of a table, and "SDQ: Considerate (Parent1)" to a column 2 of the same table.
COLUMN 1
p1consid
p1restles
p1somatic
COLUMN 2
SDQ: Considerate (Parent1)
SDQ: Restless (Parent1)
SDQ: Headache, stomach-ache (Parent1)
Thank you!
There's a bunch of assumptions in this code but try this for a start.
It assumes the source documents formatting is as you described and that a 2-column table exists in the destination document. The table is the first table, there are no header rows and it is a single row table.
Sub CopyStrings()
Dim docSrc As word.Document, docDst As word.Document
Dim rng As word.Range, tbl As word.Table, tRng As word.Range
Set docSrc = Documents.Open("Your Source Doc")
Set docDst = Documents.Open("Your Destination Doc")
Set rng = docSrc.Content
Set tbl = docDst.Content.Tables(1)
With rng.Find
.ClearFormatting
.Format = False
.Forward = True
.Text = "p1"
.Wrap = wdFindStop
.Execute
Do While .found
rng.MoveEnd word.WdUnits.wdWord, Count:=1
Set tRng = tbl.rows(1).Cells(1).Range
tRng.MoveEnd word.WdUnits.wdCharacter, Count:=-1
tRng.Collapse word.WdCollapseDirection.wdCollapseEnd
tRng.Text = rng.Text & vbCr
rng.Collapse word.WdCollapseDirection.wdCollapseEnd
rng.MoveStart word.WdUnits.wdWord, Count:=1
rng.MoveStart word.WdUnits.wdCharacter, Count:=1
rng.MoveEnd word.WdUnits.wdParagraph, Count:=1
Set tRng = tbl.rows(1).Cells(2).Range
tRng.MoveEnd word.WdUnits.wdCharacter, Count:=-1
tRng.Collapse word.WdCollapseDirection.wdCollapseEnd
tRng.Text = rng.Text
rng.Collapse word.WdCollapseDirection.wdCollapseEnd
.Execute
Loop
End With
End Sub
Related
I have a Word document using font size 8 in which I manually have created some index objects using the shortcut Shift-Alt-X. It might look like this, showing formatting symbols:
some·words·in·bold{·XE·"bold"},·some·in·italic{·XE·"italic"}
Actually, the "XE" is set with font size 11 (my normal standard), but I can't reproduce that here. So I have written a macro which intends to normalize the index object when called from just after the ”}”-sign. It extends the range backwards to include the ”{”-sign and resets the selection to standard values:
Private Sub NormalizeEntry()
Dim rng As Range
Set rng = Selection.Range
With rng
.MoveStartUntil Cset:="{", Count:=-100
.MoveStart Unit:=wdCharacter, Count:=-1
.Select
.Font.Size = 8
.Font.ColorIndex = wdBlack
.Font.Bold = False
.Font.Italic = False
.Select
End With
End Sub
The macro works fine if I apply it after a standard sequence of words enclosed in brackets like
Behold, {here are some words enclosed in brackets} and more words...
("brackets" written with a colored font, which I also can't reproduce here), but it fails when used after an XE-entry. The entry gets selectet all right, but the font is not changed. What am I missing here?
As John advises, you should set the font attributes of the underlying Style to 8pt. As for the bold & italic formatting:
Bold should be applied via the Strong character Style; and
Italic should be applied via the Emphasis character Style.
To revert anything with the wrong format to that of the underlying paragraph Style, simply select the offending content and press Ctrl-Space.
Here's a way of achieving the same thing for all fields via a macro:
Sub FieldReset()
Application.ScreenUpdating = False
Dim Fld As Field, Rng As Range
For Each Fld In ActiveDocument.Fields
With Fld
Set Rng = .Code
With Rng
With .Duplicate
Do While .Fields.Count = 0
.Start = .Start - 1
Loop
Rng.Start = .Start + 1
End With
Do While .Fields.Count = 0
.End = .End + 1
Loop
.Start = .Start - 1
.Font.Reset
End With
End With
Next
Application.ScreenUpdating = True
End Sub
Thank you, Macropod, for your input. However your solution is not what I am looking for, I want to format the field upon insertion.
By experimenting I found a useful solution: Don’t use ActiveDocument.Indexes.MarkEntry, but construct the XE-field yourself using rng.Fields.Add. Here is my result:
Sub TextToNormal(rng As Range)
With rng.Font
.Bold = False
.Italic = False
.Underline = wdUnderlineNone
.StrikeThrough = False
.DoubleStrikeThrough = False
.Color = wdColorAutomatic
.Engrave = False
.Superscript = False
.Subscript = False
End With
End Sub
Function SkipSurroundingSpaces(rng As Range) As Range
With rng
.MoveStartWhile Cset:=" ", Count:=wdForward
.MoveEndWhile Cset:=" ", Count:=wdBackward
.Select
End With
End Function
Sub TestSkipSurroundingSpaces()
Dim rng As Range
Set rng = Selection.Range
SkipSurroundingSpaces rng
End Sub
Sub InsertXEfield()
Dim Xref As String
Dim rng As Range
Set rng = Selection.Range
With rng
SkipSurroundingSpaces rng
Xref = .Text
.Collapse wdCollapseEnd
.Fields.Add Range:=rng, Type:=wdFieldEmpty, _
PreserveFormatting:=False
.Select
.MoveEnd Unit:=wdCharacter, Count:=4
Debug.Print .Start, .End
TextToNormal rng
.MoveStart Unit:=wdCharacter, Count:=2
Debug.Print .Start, .End
.Collapse wdCollapseStart
.InsertAfter "XE """ & Xref & """"
.MoveStart Unit:=wdCharacter, Count:=4
.MoveEnd Unit:=wdCharacter, Count:=-1
.Italic = True
.Bold = True
.Font.ColorIndex = wdViolet
End With
End Sub
Comments:
When selecting a word the range could include a trailing space. This is removed by a call to SkipSurroundingSpaces. Next the selected word is read (actually I take Xref from a form’s inputbox, where it can be changed to something more appropriate, say changing “exoplanets” to “exoplanet”). The range is collapsed to its end and an empty field is inserted. This field might have inherrited formatting from the entry, so it is set back to normal by calling TextToNormal. Then the range is moved into the field (passing by “{·”) and the XE-text is inserted. Finally the range is reduced to include the inserted word only and this word can now be formatted to your heart’s content or as instructed by information from a user form.
(Code and comments updated 2022-06-08)
I'm generating some security report in Microsoft Word - importing SOAP xml requests and responses...
I want to automate this process as much as I can and I need to highlight some text in these requests/responses. How to do that? In general I need to highlight non-standart inputs in requests (every time different - bad data types and so on) and fault strings in responses (in majority looks like this <faultstring>some error</faultstring>).
Heres code Im trying:
Sub BoldBetweenQuotes()
' base for a quotes finding macro
Dim blnSearchAgain As Boolean
' move to start of doc
Selection.HomeKey Unit:=wdStory
' start of loop
Do
' set up find of first of quote pair
With Selection.Find
.ClearFormatting
.Text = "<faultstring>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If Selection.Find.Found Then
Selection.MoveRight Unit:=wdCharacter, Count:=1
' switch on selection extend mode
Selection.Extend
' find second quote of this pair
Selection.Find.Text = "</faultstring>"
Selection.Find.Execute
If Selection.Find.Found Then
Selection.MoveLeft Unit:=wdCharacter, Count:=Len(Selection.Find.Text)
' make it bold
Selection.Font.Bold = True
Selection.Collapse Direction:=wdCollapseEnd
Selection.MoveRight Unit:=wdCharacter, Count:=1
blnSearchAgain = True
Else
blnSearchAgain = False
End If
Else
blnSearchAgain = False
End If
Loop While blnSearchAgain = True
End Sub
It highlights just the first faultstring, but other appearences stay unformated nad I dont know why.... Thanks for your reply.
The most efficient way to do this is to work with multiple Range objects. Think of a Range as being like an invisible selection, with the important difference that, while there can be but one Selection object there can be multiple Range objects in your code.
I've adapted your code, adding three Range objects: one for the entire document; one for finding the starting tag; one for finding the end tag. The Duplicate property is used to "copy" one Range from another (this due to an oddity in Word if you Set one Range to another, which links them).
For clarity I also added a couple more Boolean test values for your Ifcomparisons. In my experience, it's more reliable to pick up the "success" directly from Execute than to rely on Find.Found after-the-fact.
Sub BoldBetweenQuotes()
' base for a quotes finding macro
Dim blnSearchAgain As Boolean
Dim blnFindStart As Boolean
Dim blnFindEnd As Boolean
Dim rngFind As word.Range
Dim rngFindStart As word.Range
Dim rngFindEnd As word.Range
Set rngFind = ActiveDocument.content
Set rngFindStart = rngFind.Duplicate
Do
' set up find of first of quote pair
With rngFindStart.Find
.ClearFormatting
.Text = "<faultstring>"
.Replacement.Text = ""
.Forward = True
.wrap = wdFindStop
blnFindStart = .Execute
End With
If blnFindStart Then
rngFindStart.Collapse wdCollapseEnd
Set rngFindEnd = rngFindStart.Duplicate
rngFindEnd.Find.Text = "</faultstring>"
blnFindEnd = rngFindEnd.Find.Execute
If blnFindEnd Then
rngFindStart.End = rngFindEnd.Start
' make it bold
rngFindStart.Font.Bold = True
rngFindStart.Start = rngFindEnd.End
rngFindStart.End = rngFind.End
blnSearchAgain = True
Else
blnSearchAgain = False
End If
Else
blnSearchAgain = False
End If
Loop While blnSearchAgain = True
End Sub
I have a Word document with a table of 3 columns and an unknown number of rows and
I need a macro that can search for the string "Sum" in column 1.
If an exact match is found the macro must set the typography of the two remaining cells in the row to two different typographies from Word and also delete the string "Sum" in cell 1.
The table can contain many instances of the string "sum" but they wil alwaye be in the first column.
The code I have tried, and I apologize for my lack of coding skills, but I have only been doing this for at week, works fine until the first instance of "sum" and then just quits.
I am using this code:
Sub FindSum()
Dim oTbl As Table
Dim oRow As Row
Set myRange = ActiveDocument.Content
For Each oTbl In ActiveDocument.Tables
For Each oRow In oTbl.Rows
Selection.Find.Execute FindText:="Sum", ReplaceWith:=""
If Selection.Find.Found = True Then
Selection.MoveRight Unit:=wdCell
Selection.Style = ActiveDocument.Styles("Titel")
Selection.MoveRight Unit:=wdCell
Selection.Style = ActiveDocument.Styles("Citat")
End If
Next
Next
End Sub
I hope you can help me.
this appears to work
ignores "Sum" outside of tables
tested with two tables
Option Explicit
Sub FindSum()
Dim oTbl As Table
Dim stT As Long, enT As Long
Dim stS As Long, enS As Long
With Selection.Find ' the settings remain until changed
.Text = "Sum"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
End With
For Each oTbl In ActiveDocument.Tables
oTbl.Columns(1).Select ' not sure if this is required
Do While Selection.Find.Execute
stT = oTbl.Range.Start ' table range
enT = oTbl.Range.End
stS = Selection.Range.Start ' found text range
enS = Selection.Range.End
If stS < stT Or enS > enT Then Exit Do ' text found inside table ???
Selection.Collapse wdCollapseStart
Selection.Find.Execute Replace:=wdReplaceOne
Selection.MoveRight Unit:=wdCell
Selection.Style = wdStyleTitle ' original code was invalid
Selection.MoveRight Unit:=wdCell
Selection.Style = wdStyleHeading3
Loop
Selection.Collapse wdCollapseEnd
Next
End Sub
I have a word document in which I would like to select the full text of the heading starting with enumeration 2.3.1 until (not included) the heading 2.3.2 or [End of File]. If there are 'smaller' subsections or pictures or tables in between, they should also be selected.
PS: Example:
...
2.2 Blah
Blah
2.3 Blubb
Blubb
[Start Selection]
2.3.1 Important1
Important2
[Picture: Important3]
[Table: Important4]
2.3.1.1 Important 5
Important 6
[Stop Selection]
2.3.2 Blieh
I have experimented with navigating through every paragraph, but this is quite slow. I need this feature to copy the selection afterwards (I already know how to do that ;-)).
Thank you very much for help!
Jan
This seems to work well.
Adjust the format setting so that it finds '2.3.1' etc. only in that given format type.
Sub Macro1()
Selection.WholeStory
Selection.Collapse wdCollapseStart
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Caption 1")
With Selection.Find
.Text = "2.3.1"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
End With
Selection.Find.Execute
Selection.Collapse wdCollapseStart
Dim r1 As Range
Set r1 = Selection.Range
' keep format settings, only change text
Selection.Find.Text = "2.3.2"
If Selection.Find.Execute Then
Selection.Collapse wdCollapseStart
Else
Selection.WholeStory
Selection.Collapse wdCollapseEnd
End If
Dim r2 As Range
Set r2 = ActiveDocument.Range(r1.Start, Selection.Start)
r2.Select
End Sub
This is the VBA Macro I'm using to select the text between headings. However, it only selects between any two headings of any level. It won't include smaller subheadings.
Sub SelectBetweenHeadings()
With Selection
.GoTo What:=wdGoToHeading, Which:=wdGoToPrevious
.Collapse
Dim curRange As Range
Set curRange = .Range
.Extend
.GoTo What:=wdGoToHeading, Which:=wdGoToNext
If .Range = curRange Then
.EndKey Unit:=wdStory
End If
.ExtendMode = False
End With
End Sub
I'm trying to extract bold text using the range.find method and all is peachy except if the entire range is actually bold (not likely to happen much, it's more of an edge condition).
With rngFindRange.Find
.ClearFormatting
.Font.Bold = True
Do
.Execute
If Not .Found Then
Exit Do
End If
'do something with found text'
Set rngFindRange = ActiveDocument.Range(rngFindRange.End + 1, Selection.End)
Loop
The above matches bold text right at the start or right at the end, even both but not when the entire range is bold. I think I might have to test the range.font.bold = true before searching through the range. What does stackoverflow think?
This should find any bold text:
Sub SearchBoldText()
Dim rng As Range
Set rng = ThisDocument.Range(0, 0)
With rng.Find
.ClearFormatting
.Format = True
.Font.Bold = True
While .Execute
rng.Select
rng.Collapse direction:=wdCollapseEnd
Wend
End With
Set rng = Nothing
End Sub