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
Related
I know, I have seen this link: Word 2016- VBA- How To Insert Row Below Selected Row In A Table?
But, unfortunately, even if it may be trivial, I don't understand how to do it.
Here is what I want to do: 1)to add row(s) (from docSource) at the end of a Table (first part working well) OR 2)to add row(s) (from docSource) above the selected row (row selected on docTarget) (second part struggling to find the right way).
Dim docTarget As Document
Dim docSource As Document
Set docTarget = ActiveDocument
Set docSource = Documents.Open(strFileName)
IF SOMETHING THEN
'1) Working code
Dim myRange As Object
Set myRange = docTarget.Content
myRange.Collapse Direction:=wdCollapseEnd
myRange.FormattedText = docSource.Tables(2).Range.FormattedText
ELSE
'2) Can't figure it out
Dim myRange2 As Object
Set myRange2 = docTarget.Content
myRange2.Select 'What? - the row I already highlighted -
Selection.InsertRowsBelow
myRange2.FormattedText = docSource.Tables(2).Range.FormattedText
ENDIF
docSource.Close (0)
Set docSource = Nothing
Set docTarget = Nothing
For information, my tables from docSource or docTarget got 3 columns and no merge cells.
I welcome any ideas or tips.
Thanks.
I think I found the answer, thanks to the patience of Timothy Rylatt. But if you have any positive critics or improvements (better coding), please do not hesitate to comment.
First, before opening my userform, I got this:
mySelectedRow = Selection.Information(wdEndOfRangeRowNumber)
mySlectedRow declare as Public
Second, in the userform, I got this:
Private Sub btnOK_Click()
Dim strFileName As String
strFileName = ActiveDocument.Path & "\something\" & cboFileOption.Text
' Open selected item as docSource and assign docTarget to this document
Dim docTarget As Document
Dim docSource As Document
Set docTarget = ActiveDocument
Set docSource = Documents.Open(strFileName)
' Fill docTarget with the content of docSource
Dim myRange As Object
Set myRange = docTarget.Content
If Me.optEndTable.Value = True Then
myRange.Collapse Direction:=wdCollapseEnd
myRange.FormattedText = docSource.Tables(2).Range.FormattedText
Else
docSource.Tables(2).Range.FormattedText.Copy
docTarget.Content.Tables(1).Rows(mySelectedRow).Select
Selection.Rows(Selection.Rows.Count).Range.Paste
End If
' Close selected item (docSource) without saving
docSource.Close (0)
Set docSource = Nothing
Set docTarget = Nothing
' End
Me.Hide
End Sub
Hope that make sense.
Thanks
I'm trying to set AutoFitBehavior of a Word table to fit both content and window - clicking 'AutoFit Contents' button, then 'AutoFit Window' gives the result I want to get. The problem is, when I do this using VBA, the formatting is different. Interestingly enough, when I run the macro Step By Step (F8) it gives expected result (same as UI).
Here's my code:
Documents(1).Activate
With ActiveDocument.Tables(2)
.AllowAutoFit = True
.AutoFitBehavior 1
.AutoFitBehavior 2
End With
As you can see, it's pretty simple - I can't find any reason for it to work incorrectly.
Also I don't think the issue is related to using 'ActiveDocument' property, as in the full macro this code is executed directly on a newly created, named document, so I'm sure it's addressing a correct table in a correct file.
I am aware that I can set column widths with PreferredWidth property, but it would be much simpler to use AutoFit, as I don't always know what length will my data have.
Is there a way to make this method work as when called from UI?
Edit:
As per Cindy Meister's request, I'm adding snippet from actual code I'm using:
Set wordApp = CreateObject("Word.Application")
Set wordDoc = wordApp.Documents.Add(strPath)
With wordDoc
.Tables.Add Range:=wordDoc.Bookmarks("tableBookmark").Range, NumRows:=licenceRows, NumColumns:=3
'[omitted: populating the table]
.Tables(1).Split(splitRow)
With .Tables(2)
.Range.Collapse Direction:=0
.Range.InsertBreak Type:=7
.AllowAutoFit = True
.AutoFitBehavior 1
.AutoFitBehavior 2
End With
End With
It's called from an Excel macro I'm using to create a report file from template. I'm using Office 2013.
Also I've noticed another thing today: when I set wordApp.Visible = True, scroll to the table and literally look at the method working - it formats correctly. It's like Word application won't use this method correctly, until it has to show you every single step (as with step-by-step run).
Thanks to Cindy's answer and following comment I realised my mistake - I thought Auto Fit would make columns fit to any text, including text with line-breaking characters like spaces. Comes out it doesn't work that way.
In the end, to format the table as I wanted (window-wide table, columns fit to content) I used the following code:
'Table should fit the page and fit the contents
Sub TestFormatTableStructure()
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim tbl1 As Word.Table, tbl2 As Word.Table
On Error GoTo ErrHandler
Set wordApp = New Word.Application
Set wordDoc = wordApp.Documents.Add
wordApp.ScreenUpdating = False
With wordDoc
Set tbl1 = .Tables.Add(Range:=wordDoc.Paragraphs.Last.Range, _
NumRows:=6, NumColumns:=3, _
DefaultTableBehavior:=wdWord9TableBehavior, _
AutoFitBehavior:=wdAutoFitContent) 'autofit content
With tbl1
'[omitted: populating the table]
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
Set tbl2 = tbl1.Split(4)
'dont have to set formatting again for second table, its inherited
With tbl2
'[do things]
End With
End With
ErrHandler:
wordApp.Visible = True
wordApp.ScreenUpdating = True
Set tbl1 = Nothing
Set tbl2 = Nothing
Set rngtlb = Nothing
Set wordDoc = Nothing
Set wordApp = Nothing
End Sub
Thanks for the additional info. For the future, in such a case it would help if you include the automation code for running from Excel, as well, since the issue could be with that interface...
I ran the following code in Office 2013 (as well as in 2010) and it worked as expected: the table fit the width of the page (margin to margin) and the cells expanded to fit the content.
In contrast to what you have, I've used the optional arguments in Tables.Add to set the default behavior to allow AutoFit when creating the table. Then I didn't need to set all of them after-the-fact.
Notice also my use of object variables for the tables and the Ranges, releasing the objects, and updating the screen.
'Table should fit the page and fit the contents
Sub TestFormatTableStructure()
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim tbl1 As Word.Table, tbl2 As Word.Table
Dim rngTbl As Word.Range
On Error GoTo ErrHandler
Set wordApp = New Word.Application
Set wordDoc = wordApp.Documents.Add
wordApp.ScreenUpdating = False
With wordDoc
Set tbl1 = .Tables.Add(Range:=wordDoc.Paragraphs.Last.Range, _
NumRows:=6, NumColumns:=3, _
DefaultTableBehavior:=wdWord9TableBehavior, _
AutoFitBehavior:=2)
'[omitted: populating the table]
Set tbl2 = tbl1.Split(4)
With tbl2
Set rngTbl = .Range
rngTbl.Collapse Direction:=0
rngTbl.InsertBreak Type:=7
'.AllowAutoFit = True
'.AutoFitBehavior 1
.AutoFitBehavior 2
End With
End With
ErrHandler:
wordApp.Visible = True
wordApp.ScreenUpdating = True
Set tbl1 = Nothing
Set tbl2 = Nothing
Set rngtlb = Nothing
Set wordDoc = Nothing
Set wordApp = Nothing
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'm composing an email using VB.Net which is opened in Outlook 2013. I need to the contents to be displayed in its default font which is set by the user.
Now i need to get the default font and set to the email. When i tried it returns null at one place.
//Code:
Private m_valDefaultFontSpec As DefaultFont
Sub GetDefaultFontSpec(Optional blnGetReplyFont As Boolean = False)
Dim objDoc As Document
Dim rng As Range
Dim objDummy As MailItem
On Error Resume Next
' Create a "dummy" mail object,
Set objDummy = Application.CreateItem(olMailItem)
' Get the document object from the current "dummy mail" object.
Set objDoc = objDummy.GetInspector.WordEditor //returns nothing here
' Get the range of the word document object.
Set rng = objDoc.Range
' Get some font properties from the given range.
With rng
m_valDefaultFontSpec.Name = .Font.Name
m_valDefaultFontSpec.Size = .Font.Size
m_valDefaultFontSpec.Bold = .Font.Bold
m_valDefaultFontSpec.Color = .Font.Color
m_valDefaultFontSpec.Italic = .Font.Italic
End With
' Finished with the "dummy" mail, close it.
objDummy.Close olDiscard
On Error GoTo 0
End Sub
Where am i wrong? Any help?
Source
WordEditor property might not be available until the message is shown.
Try to simply set the MailItem.HTMLBody property.
I'm trying to create a macro to look for to specific expressions and remove that content.
For example I need to remove everything that goes from the word "NOTIFICATION" to the expression "Good Morning" (but keeping "Good Morning, if possible).
I have a code to remove one line, but cannot figure out how to do it with a selection, because I don't have the same number of lines every time. Could be 3 or up to 9, more or less.
The code I have is like this (I've removed the parts of the code that did other things that are not related to this problem I have):
Private Sub ProcessMsg(msg As MailItem)
On Error GoTo ErrorHandlerProcessMsg
Dim msg2 As Outlook.MailItem
Dim msgDoc As Word.Document
Dim msgDoc2 As Word.Document
Dim objSel As Word.Selection
Set msg2 = Application.CreateItem(olMailItem)
Set msgDoc = msg.GetInspector.WordEditor
Set msgDoc2 = msg2.GetInspector.WordEditor
msgDoc.Select
msgDoc.Windows(1).Selection.Copy
msgDoc2.Windows(1).Selection.PasteAndFormat wdPasteDefault
Set objSel = msgDoc2.Windows(1).Selection
With objSel
.Find.Execute "NOTIFICATION"
.Collapse wdCollapseStart
.MoveEnd WdUnits.wdStory, 1
.Delete
End With
Set objSel = msgDoc2.Windows(1).Selection
With objSel
.MoveStart WdUnits.wdStory, -1
.Collapse wdCollapseStart
.MoveEnd WdUnits.wdParagraph, 1
.Delete
End With
Set msgDoc = Nothing
Set msgDoc2 = Nothing
Set objSel = Nothing
Set msg2 = Nothing
Exit Sub
ErrorHandlerProcessMsg:
Set msgDoc = Nothing
Set msgDoc2 = Nothing
Set objSel = Nothing
Set msg2 = Nothing
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Could anyone enlighten me?
This does what you want (from what I understand). Just paste this function inside one of the word document's code objects and run it (have tried on Word, rather than Excel). It's mainly to show you how you could go by handling such a problem.
Sub LineRemover()
Dim doc As Document
Set doc = ActiveDocument
Dim myParagraph As Paragraph
Dim mySentences As Sentences
Dim mySentence As Range
Dim deleted As Boolean
deleted = False
For Each myParagraph In doc.Paragraphs
Set mySentences = myParagraph.Range.Sentences
For Each mySentence In mySentences
If InStr(mySentence, "Good morning") <> 0 Then
'"Good morning" is present inside this line; exit the loop!
Exit For
ElseIf deleted Then
'"NOTIFICATION" was already deleted, need to remove all subsequent lines!
mySentence.Delete
ElseIf InStr(mySentence, "NOTIFICATION") <> 0 Then
'"NOTIFICATION" is present inside this line; delete it!
mySentence.Delete
deleted = True 'Tell the program you've deleted it!
End If
Next
If deleted Then
Exit For
End If
Next
End Sub
Extra details : InStr(String1, String2) will return the position at which String2 is found inside String1