I have a MS Excel worksheet with custom script. Part of this script is supposed to edit information in a MS Word document.
The thing that needs to be edited is text stored in a table cell in the Word document. I managed to edit the text it self, but I need to set part of the text to bold.
How can I do this?
Here is an example. Say I need to enter "123456789" in the table cell(1,1) and set the first characters "12345" to bold. Like this:
From Excel. Here is what I tried:
Dim SavePath as string
SavePath = "... path ..."
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open(SavePath)
objWord.Visible = True
objDoc.Tables(1).Cell(1, 1).Range.Text = "123456789"
'So far, so good. The next part (how to set part of text to bold) is what I can't figure out. This does not work:
With objDoc.Tables(1).Cell(1, 1).Range(Start:=0, End:=5)
.Content.Font.Bold = True
End With
I know I can set a whole single cell to bold with this:
objDoc.Tables(1).Cell(ThisRow, ThisCol).Range.Bold = True
But can I address specific characters within a cell?
Can anyone help me?
Try this
Tried and tested in Windows 7 pr. 64, Word 2010 32.
Sub test()
Set objDoc = ActiveDocument
objDoc.Tables(1).Cell(1, 1).Range.Text = "123456789"
Set myrange = objDoc.Tables(1).Cell(1, 1).Range.Paragraphs(1).Range
MsgBox myrange.Text
lStartPos = myrange.Characters(1).Start
lEndPos = myrange.Characters(5).End
Set myrange = objDoc.Range(lStartPos, lEndPos)
myrange.Font.Bold = True
End Sub
you should use this.
Sub test()
Dim SavePath As String
SavePath = "... path ..."
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open(SavePath)
objWord.Visible = True
objDoc.Tables(1).Cell(1, 1).Range.Text = "123456789"
Set myrange = objDoc.Tables(1).Cell(1, 1).Range.Paragraphs(1).Range
MsgBox myrange.Text
lStartPos = myrange.Characters(1).Start
lEndPos = myrange.Characters(5).End
Set myrange = objDoc.Range(lStartPos, lEndPos)
myrange.Font.Bold = True
End Sub
Related
I have a template document which contains a number of bookmarks used thus;
mDoc.Bookmarks(bookmark).Range.Text = "My test".
I would now like to add a new bookmark at the position in the doc at the end of the string "My test" but cannot find any guidance on how to specify the range in;
Dim Bookmarks As Word.Bookmarks
Dim myBookmark As Word.Bookmark
Dim bookmarkRange As Word.Range
Dim Selection As Word.Selection
'doc = mWord.ActiveDocument
Selection = mWord.Selection
bookmarkRange = Selection.Range
Bookmarks = mDoc.Bookmarks
myBookmark = Bookmarks.Add("MyBookmark", bookmarkRange) 'this works but puts it at the start of the doc
mDoc.Bookmarks("MyBookmark").Range.Text = "text inserted at MyBookmark"
How would I do that?
Your existing code does not add text to the bookmarked range; it inserts that text after the bookmark. To add text to a bookmarked range, use something like the following VBA code:
Dim BkMkRng As Range
With ActiveDocument
If .Bookmarks.Exists("MyBookmark") Then
Set BkMkRng = .Bookmarks("MyBookmark").Range
BkMkRng.Text = "My Text"
.Bookmarks.Add "MyBookmark", BkMkRng
End If
End With
To insert an new bookmark after that range, simply use something along the lines of:
With ActiveDocument
If .Bookmarks.Exists("MyBookmark") Then
Set BkMkRng = .Bookmarks("MyBookmark").Range
BkMkRng.Collapse wdCollapseEnd
BkMkRng.Text = "My New Text"
.Bookmarks.Add "MyNewBookmark", BkMkRng
End If
End With
From where you are, you could replace
mDoc.Bookmarks("MyBookmark").Range.Text = "text inserted at MyBookmark"
with
Dim myRange As Word.Range
myRange = mDoc.Bookmarks(myBookmark).Range
myRange.Text = "text inserted at MyBookmark"
myRange.Collapse(Word.WdCollapseDirection.wdCollapseEnd)
myRange.Bookmarks.Add("MyNewBookmark")
I have the code below without using Selection.
Sub Format paragraph()
Dim wdDoc As Document
With wdDoc.Range.Find
.Font.Size = 12
.Text = "?"
.Execute
End With
End Sub
When the character with font size = 12 is found, how can I change the format of the current paragraph? for example:
wdDoc.Paragraph(current).Font.Size = 14
wdDoc.Paragraph(current).Font.Color = wdBlue
Thanks for any help.
The trick is to work with a specific Range object, which can be used to access its "parent" paragraph. When Find.Execute is successful, the Range being searched contains the found item (same as the selection jumps to the found item). For example:
Sub Format paragraph()
Dim rng as Range, para as Paragraph
Dim wdDoc As Document
Set wdDoc = ActiveDocument. 'Missing in code in question...
Set rng = wdDoc.Content 'Content returns the Range
With rng.Find
.Font.Size = 12
.Text = "?"
If .Execute = True Then
Set para = rng.Paragraphs(1)
para.Font.Size = 14
para.Font.Color = wdBlue
End If
End With
End Sub
I am trying to add captions to a word document, using VBA. I am using the following code. The data starts off as tables in an Excel spreadsheet, with one per sheet. We are trying to generate a list of tables in the word document.
The following code loads starts editing a word template:
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add("Template path")
' Moving to end of word document
objWord.Selection.EndKey END_OF_STORY, MOVE_SELECTION
' Insert title
objWord.Selection.Font.Size = "16"
objWord.Selection.Font.Bold = True
objWord.Selection.TypeText ("Document name")
objWord.Selection.ParagraphFormat.SpaceAfter = 12
objWord.Selection.InsertParagraphAfter
The following code loops through the sheets in the worksheet and adds the tables and headers.
' Declaring variables
Dim Wbk As Workbook
Dim Ws As Worksheet
Dim END_OF_STORY As Integer: END_OF_STORY = 6
Dim MOVE_SELECTION As Integer: MOVE_SELECTION = 0
Dim LastRow As Integer
Dim LastColumn As Integer
Dim TableCount As Integer
Dim sectionTitle As String: sectionTitle = " "
' Loading workbook
Set Wbk = Workbooks.Open(inputFileName)
' Moving to end of word document
objWord.Selection.EndKey END_OF_STORY, MOVE_SELECTION
' Looping through all spreadsheets in workbook
For Each Ws In Wbk.Worksheets
' Empty Clipboard
Application.CutCopyMode = False
objWord.Selection.insertcaption Label:="Table", title:=": " & Ws.Range("B2").Text
In the cell B2, I have the following text: "Table 1: Summary". I am hoping for the word document to have a header which reflects this text. The problem is the table number is repeated twice, and I get output: "Table 1: Table 1: Summary". I tried the following alterations, both of which resulted in errors:
objWord.Selection.insertcaption Label:="", title:="" & Ws.Range("B2").Text
objWord.Selection.insertcaption Label:= Ws.Range("B2").Text
What am I doing wrong, and more generally how does the insertcaption method work?
I have tried reading this, but am confused by the syntax.
https://msdn.microsoft.com/en-us/vba/word-vba/articles/selection-insertcaption-method-word
One of the built-in features of using the Caption style in MS Word is the automatic numbering it applies and dynamically adjust in your document. You are explicitly trying to manage the table numbering yourself - which is fine - but you'll then have to un-do some of Word's automatic helpful numbering in your code.
Working from Excel, I've tested the code below to set up a test document with Captions and then a quick routine to remove the automatic part of the label. This example code works as a stand-alone test to illustrate how I worked it, leaving it to you to adapt to your own code.
The initial test sub simply establishes the Word.Application and Document objects, then creates three tables with following paragraphs. Each of the tables has it's own caption (which shows the doubled up label, due to the automatic labeling from Word). The code throws up a MsgBox to pause so you can take a look at the document before it's modified.
Then the code goes back and searches the entire document for any Caption styles and examines the text within the style to find the double label. I made the assumption that a double label is present if there are two colons ":" detected in the caption text. The first label (up to and past the first colon) is removed and the text replaced. With that, the resulting document looks like this:
The code:
Option Explicit
Sub test()
Dim objWord As Object
Dim objDoc As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.documents.Add
Dim newTable As Object
Set newTable = objDoc.Tables.Add(Range:=objDoc.Range, NumRows:=3, NumColumns:=1)
newTable.Borders.Enable = True
newTable.Range.InsertCaption Label:="Table", Title:=": Table 1: summary xx"
objDoc.Range.InsertParagraphAfter
objDoc.Range.InsertAfter "Lorem ipsum"
objDoc.Characters.Last.Select
objWord.Selection.Collapse
Set newTable = objDoc.Tables.Add(Range:=objWord.Selection.Range, NumRows:=3, NumColumns:=2)
newTable.Range.InsertCaption Label:="Table", Title:=": Table 2: summary yy"
newTable.Borders.Enable = True
objDoc.Range.InsertParagraphAfter
objDoc.Range.InsertAfter "Lorem ipsum"
objDoc.Characters.Last.Select
objWord.Selection.Collapse
Set newTable = objDoc.Tables.Add(Range:=objWord.Selection.Range, NumRows:=3, NumColumns:=3)
newTable.Range.InsertCaption Label:="Table", Title:=": Table 3: summary zz"
newTable.Borders.Enable = True
objDoc.Range.InsertParagraphAfter
objDoc.Range.InsertAfter "Lorem ipsum"
MsgBox "document created. hit OK to continue"
RemoveAutoCaptionLabel objWord
Debug.Print "-----------------"
End Sub
Sub RemoveAutoCaptionLabel(ByRef objWord As Object)
objWord.Selection.HomeKey 6 'wdStory=6
With objWord.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Style = "Caption"
.Text = ""
.Forward = True
.Wrap = 1 'wdFindContinue=1
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute()
RemoveDoubleLable objWord.Selection.Range
objWord.Selection.Collapse 0 'wdCollapseEnd=0
Loop
End With
End Sub
Sub RemoveDoubleLable(ByRef capRange As Object)
Dim temp As String
Dim pos1 As Long
Dim pos2 As Long
temp = capRange.Text
pos1 = InStr(1, temp, ":", vbTextCompare)
pos2 = InStr(pos1 + 1, temp, ":", vbTextCompare)
If (pos1 > 0) And (pos2 > 0) Then
temp = Trim$(Right$(temp, Len(temp) - pos1 - 1))
capRange.Text = temp
End If
End Sub
I have several word files. They are build like this
text
text
text
Name: Mick
Date: 1-1-1
text
text
Item: Item11 material: Gold
text
text
I am building a macro that can open a word file, put the name in Cell A1 and put the item in Cell A2. I have found a code on internet and adjusted it a little. The following code makes a selection from the beginning of the word doc until a word is found and copies that selection in a given cell.
I hope someone can show me how i can adjust this so the selection begins right before the needed value an stops after it
code below is for item:
Dim wdApp As Object, wdDoc As Object, wdRng As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.Visible = True
Set wdDoc = .Documents.Open("path", False, True, False)
With wdDoc
Set wdRng = .Range(0, 0)
With .Range
With .Find
.Text = "material"
.Forward = True
.MatchWholeWord = True
.MatchCase = True
.Execute
End With
If .Find.found = True Then
wdRng.End = .Duplicate.Start
Sheets("sheet1").Range("A2").value = wdRng
End If
End With
.Close False
End With
.Quit
End With
Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing
Anyone any suggestions?
Try the procedure below. It will open the specified Word document, parse the required values via Regular Expressions, place those values into cells A1 and A2, and then close the Word document.
When calling the procedure, specify the full path and filename of the Word document.
For example: SetNameAndItem "C:\Temp\Doc1.docx"
Public Sub SetNameAndItem(strPath As String)
Dim wdApp As Object: Set wdApp = CreateObject("Word.Application")
Dim wdDoc As Object: Set wdDoc = wdApp.Documents.Open(strPath, False, True, False)
Dim objRegEx As Object: Set objRegEx = CreateObject("VBScript.RegExp")
Dim objMatches As Object
On Error GoTo ProcError
With objRegEx
.Global = False
.MultiLine = True
.IgnoreCase = False
.Pattern = "^Name:\s(.*?)$"
End With
Set objMatches = objRegEx.Execute(wdDoc.Content)
If objMatches.Count = 0 Then
Debug.Print "Name: No match."
Else
Range("A1").Value = objMatches(0).SubMatches(0)
End If
objRegEx.Pattern = "^Item:\s(.*?)\smaterial"
Set objMatches = objRegEx.Execute(wdDoc.Content)
If objMatches.Count = 0 Then
Debug.Print "Item: No match."
Else
Range("A2").Value = objMatches(0).SubMatches(0)
End If
ProcExit:
On Error Resume Next
wdDoc.Close False
wdApp.Quit
Set objMatches = Nothing
Set objRegEx = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
Exit Sub
ProcError:
MsgBox "Error# " & Err.Number & vbCrLf & Err.Description, , "SetNameAndItem"
Resume ProcExit
End Sub
Result:
Note: Please ensure that the line breaks in your Word document consist of the normal Carriage Return / Line Feed character combination (the results of pressing pressing the Enter key). When I copied/pasted the text from your Question, the document looked as expected, but what appeared to be line feeds were actually Vertical Tab characters, so the Regular Expressions did not work. I'm not saying there was any error on your part, it's probably an artifact of pasting text the web page. Just something to be aware of.
UPDATE:
If the Regular Expressions in the above code don't work, then perhaps it was not a copy/paste issue after all, and you really do have Vertical Tab characters in your document. If that's the case, try modifying the SetNameAndItem procedure in the Excel VBA code as follows.
Replace these two lines (which use ^ and $ to represent start and end of line, respectively):
.Pattern = "^Name:\s(.*?)$"
objRegEx.Pattern = "^Item:\s(.*?)\smaterial"
With these two lines (which use \v to represent vertical tab):
.Pattern = "\vName:\s(.*?)\v"
objRegEx.Pattern = "\vItem:\s(.*?)\smaterial"
Here is a possible solution of your problem:
Use this function to read the word file:
Option Explicit
Public Function f_my_story() as string
Dim wdApp As Object
Dim wdDoc As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.Visible = True
Set wdDoc = .Documents.Open("C:\Users\v\Desktop\text.docx", False, True, False)
f_my_story = wdDoc.Range(0, wdDoc.Range.End)
wdDoc.Close False
.Quit
End With
End Function
Once you have read the file, you get a string. Now you need a macro, which separates the string by space and it returns the values, that are after the values you are looking for.
You can write those values anywhere you want.
I am new to VBA and I am trying to put together a macro in Excel. This macro is to search a Word document for a specific text string and return the page number where it is located (i.e. the column will say "### is found on page # of the document").
I seem to be very close to what I want. The macro finds the text and I can get it to tell me it found/didn't find it. However, when I run it with code to return the page number, it tells me the index is out of range. I'm sure the difficulty is with my limited understanding of the objects and their properties.
Any help is appreciated!
Sub OpenWordDoc()
Set wordapp = CreateObject("word.Application")
wordapp.Visible = True
wordapp.Activate
wordapp.Documents.Open "filename.docx"
Set findRange = Sheet1.Range("D4:D8")
For Each findCell In findRange.Cells
Set rngFound = wordapp.ActiveDocument.Range.Find
rngFound.Text = findCell.Value
rngFound.Execute
If rngFound.Found Then
findCell.Offset(columnOffset:=1) = rngFound.Parent.Information(wdActiveEndPageNumber)
Else
findCell.Offset(columnOffset:=1) = findCell.Value
End If
Next findCell
wordapp.Quit
Set wordapp = Nothing
End Sub
Edit 1: I have tried this on a completely different computer and different versions of Word and Excel. The same message pops up. The error is this piece - rngFound.Parent.Information(wdActiveEndPageNumber) - and I think the rngFound.Parent is not acting as a "selection". I also tried replacing the wdActiveEndPageNumber with wdNumberOfPagesInDocument just to see if it was the specific value and got the same error message.
Try something like this:
Sub OpenWordDoc()
Dim wordapp As Word.Application
Dim findRange As Excel.Range
Dim findCell As Excel.Range
Dim rngFound As Word.Range
Set wordapp = CreateObject("word.Application")
wordapp.Visible = True
wordapp.Activate
wordapp.Documents.Open "filename.docx"
Set findRange = Sheet1.Range("D4:D8")
For Each findCell In findRange.Cells
Set rngFound = wordapp.ActiveDocument.Range
With rngFound.Find
.Text = findCell.Value
.Execute
End With
If rngFound.Find.Found Then
findCell.Offset(columnOffset:=1) = rngFound.Information(wdActiveEndPageNumber)
Else
findCell.Offset(columnOffset:=1) = findCell.Value
End If
Next findCell
wordapp.Quit
Set rngFound = Nothing
Set findCell = Nothing
Set findRange = Nothing
Set wordapp = Nothing
End Sub
Hope that helps