I have the following code, but it gives an Run-time error "438" at:
wdRng.PrintOut
If I change this to
MsgBox wdRng
it does give a MsgBox with the selection. So something is wrong with the PrintOut method. Anyone any suggestions what is wrong?
Dim i As Long, wdApp As Object, wdDoc As Object, wdRng As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.Visible = True
For i = 1 To 200
Set wdDoc = .Documents.Open("\\path\Machine\Results" & i & ".doc", False, True, False)
With wdDoc
Set wdRng = .Range(0, 0)
With .Range
With .Find
.Text = "END"
.Forward = True
.MatchWholeWord = True
.MatchCase = True
.Execute
End With
If .Find.found = True Then
wdRng.End = .Duplicate.Start
wdRng.PrintOut
End If
End With
.Close False
End With
Next
.Quit
End With
Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing
There is nothing like .Printout method for Range object in MS Word.
Try this logic instead of wdRng.Printout:
wdRng.Select
wdApp.PrintOut ,,WdPrintOutRange.wdPrintSelection
or
wdDoc.PrintOut , , WdPrintOutRange.wdPrintSelection
Edit- try any of these lines for .PrintOut:
wdDoc.PrintOut , , 1
wdApp.PrintOut ,, 1
Related
I would like to apply a VBA Macro to multiple docx files. My macro find a text with a specific font and then hide it.
This is the macro that works when you execute it on a single docx file :
Sub color()
Dim Rng As Range
Dim Fnd As Boolean
G:
Set Rng = ActiveDocument.Range
Rng.Find.ClearFormatting
Rng.Find.Font.color = RGB(191, 191, 191)
Rng.Find.Replacement.ClearFormatting
With Rng.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
Fnd = .Found
End With
If Fnd = True Then
With Rng
.MoveStart wdWord, 0
.Select
With .Font
.Hidden = True
End With
End With
GoTo G
End If
End Sub
And I've found a macro on a forum that can loop on all files in a folder and I've combined to mine :
Sub Documentos()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName: strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> strDocNm Then
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
Dim Rng As Range
Dim Fnd As Boolean
G:
Set Rng = ActiveDocument.Range
Rng.Find.ClearFormatting
Rng.Find.Font.color = RGB(191, 191, 191)
Rng.Find.Replacement.ClearFormatting
With Rng.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
Fnd = .Found
End With
If Fnd = True Then
With Rng
.MoveStart wdWord, 0
.Select
With .Font
.Hidden = True
End With
End With
GoTo G
End If
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
When I execute this macro, I opens the document but does nothing.
Can someone help to combine them ?
I guess it's because of Set Rng = ActiveDocument.Range. in the loop you set Rng to active document. open a file doesn't make it activated automatically. And I see you have already assigned the opened file to wdDoc. Maybe use 'Set Rng = .Range' instead. see if it works for you.
Use the tools already built into Word.
A much simpler route to do that same effect is to create a Word character style with gray shading and apply that to all text that is to have a grey background. Then you can change all instances to a clear background by simply changing the style definition:
Sub ChangeShadedTextStyle()
ActiveDocument.Styles("Shaded Text").Font.Shading.BackgroundPatternColor = wdColorAutomatic
End Sub
I am writing a script that extract tables from Word file as copies it to a worksheet in Excel. However, the Word files I received do not have the same format and the tables I need are not always on the same page. Hence I cannot use the regular table index.
Each table is on a different page and only on that page there somewhere is a text string (may or may not be in the table itself) like 'material/material list'. What I'd like to do is scan each page of the Word document for a certain textstring and only if that string is present, use the corresponding table on that page. Is this possible and how would I go about this?
A complication of the inconsistent formatting is that on some pages, the data is not even in a table so for those files I'd like an alert if the trigger word is found on a page but no table is there.
Edited:
I have tried to redefine the range considered. My hope is that this is the easiest method; see where the keyword occurs and then use the first table after that. However this does not seem to work.
With ActiveDocument.Content.Find
.Text = "Equipment"
.Forward = True
.Execute
If .Found = True Then Set aRange = ActiveDocument.Range(Start:=0, End:=0)
End With
Edit:
I tried to combine the code from macropod with a vba in Excel that copies the table to the worksheet.
Sub LookForWordDocs()
Dim FolderName As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
Dim sFoldPath As String: sFoldPath = FolderName ' Change the path. Ensure that your have "\" at the end of your path
Dim oFSO As New FileSystemObject ' Requires "Microsoft Scripting Runtime" reference
Dim oFile As File
' Loop to go through all files in specified folder
For Each oFile In oFSO.GetFolder(sFoldPath).Files
' Check if file is a word document. (Also added a check to ensure that we don't pick up a temp Word file)
If ((InStr(1, LCase(oFSO.GetExtensionName(oFile.Path)), "doc", vbTextCompare) > 0) Or _
(InStr(1, LCase(oFSO.GetExtensionName(oFile.Path)), "docx", vbTextCompare) > 0)) And _
(InStr(1, oFile.Name, "~$") = 0) And _
((InStr(1, oFile.Name, "k") = 1) Or (InStr(1, oFile.Name, "K") = 1)) Then
' Call the UDF to copy from word document
ImpTable oFile
End If
Next
End Sub
Sub ImpTable(ByVal oFile As File)
Dim oWdApp As New Word.Application
Dim oWdDoc As Word.Document
Dim oWdTable As Word.Table
Dim oWS As Excel.Worksheet
Dim lLastRow$, lLastColumn$
Dim s As String
s = "No correct table found"
With Excel.ThisWorkbook
Set oWS = Excel.Worksheets.Add
On Error Resume Next
oWS.Name = oFile.Name
On Error GoTo 0
Set sht = oWS.Range("A1")
Set oWdDoc = oWdApp.Documents.Open(oFile.Path)
oWdDoc.Activate
'Application.ScreenUpdating = False
Dim StrFnd As String, Rng As Word.Range, i As Long, j As Long
j = 0
StrFnd = "equipment"
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = StrFnd
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
i = .Information(wdActiveEndAdjustedPageNumber)
Set Rng = Word.ActiveDocument.Goto(What:=wdGoToPage, Name:=i)
Set Rng = Rng.Goto(What:=wdGoToBookmark, Name:="\page")
If Rng.Tables.Count > 0 Then
With Rng.Tables(1)
Set oWdTable = Rng.Tables(1)
oWdTable.Range.Copy
sht.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
j = 1
End With
End If
.Start = Rng.End
.Find.Execute
Loop
End With
If j = 0 Then sht.Value = s
'Application.ScreenUpdating = True
oWdDoc.Close savechanges:=False
oWdApp.Quit
End With
Set oWS = Nothing
Set sht = Nothing
Set oWdDoc = Nothing
Set oWdTable = Nothing
Set Rng = Nothing
End Sub
For the first file, the code works fine. However on the second run I get a run-time error "The remote Server Machine does not Exist or is unavailable" on line
"Word.ActiveDocument.Range". I added a couple of qualifications for elements but this still did not solve the problem. Am I missing another line?
BTW When I place "Word" before ActiveDocument.Range the code does not work any more.
Since you've changed the text from 'material/material list' to 'Equipment', it's a bit hard to know quite what you want. Try something along the lines of:
Sub Demo()
Application.ScreenUpdating = False
Dim StrFnd As String, Rng As Range, i As Long
StrFnd = InputBox("What is the Text to Find")
If Trim(StrFnd) = "" Then Exit Sub
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = StrFnd
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
i = .Information(wdActiveEndAdjustedPageNumber)
Set Rng = ActiveDocument.GoTo(What:=wdGoToPage, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
If Rng.Tables.Count > 0 Then
MsgBox Chr(34) & StrFnd & Chr(34) & " and table found on page " & i & "."
With Rng.Tables(1)
'process this table
End With
Else
MsgBox Chr(34) & StrFnd & Chr(34) & " found on page " & i & " but no table."
End If
.Start = Rng.End
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
Note: the above code will test all pages on which the Find text is found.
Situation:
I am trying to search through a word document for Keyword/IDs contained in an excel, and add comments from the spreadsheet to the word document for every occurrence of the Keyword/IDs then save. The sample code I have runs through the list of Keyword/IDs, but only comments the first occurrence
Give:
The word file is located at C:\Test\ACBS.docx and the excel executing the VBA macro is located separately. In the Excel the search term variable “FindWord” is in column A , and the comment is the variable “CommentWord” in column B.
Problem:
How can I get this to search through the entire word document and comment each occurrence of the Keyword/IDs?
Code:
Sub Comments_Excel_to_Word()
'Author: Paul Keahey
'Date: 2017-10-30
'Name:Comments_Excel_to_Word
'Purpose: To bring in comments From Excel to Word.
'Comments: None
Dim objWord
Dim objDoc
Dim objSelection
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:\Test\ACBS.docx")
objWord.Visible = True
Set objSelection = objWord.Selection
Dim oRng As Word.range
Set oRng = objSelection.range
Set oScope = oRng.Duplicate
Dim oCol As New Collection
Dim FindWord As String
Dim CommentWord As String
Dim I As Integer
'initalize list of varables
For I = 2 To range("A1").End(xlDown).Row
FindWord = Sheet1.range("A" & I).Value
CommentWord = Sheet1.range("B" & I).Value
With oRng.Find
.Text = FindWord
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute = True
If oRng.InRange(oScope) Then
On Error Resume Next
'MsgBox "oRng.InRange(oScope)"
oCol.Add oRng.Text, oRng.Text
On Error GoTo 0
oRng.Collapse wdCollapseEnd
Else
ActiveDocument.Comments.Add oRng, CommentWord
Exit Do
End If
Loop
End With
Next I
objDoc.Save
End Sub
I'm not sure I understand the Word component of this setup, but if you want to list all comments in your Excel file, you can use the script below to do that.
Sub ShowCommentsAllSheets()
'Update 20140508
Dim commrange As Range
Dim rng As Range
Dim ws As Worksheet
Dim newWs As Worksheet
Set newWs = Application.Worksheets.Add
newWs.Range("A1").Resize(1, 4).Value = Array("Sheet", "Address", "Value", "Comment")
Application.ScreenUpdating = False
On Error Resume Next
For Each ws In Application.ActiveWorkbook.Worksheets
Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)
If Not commrange Is Nothing Then
i = newWs.Cells(Rows.Count, 1).End(xlUp).Row
For Each rng In commrange
i = i + 1
newWs.Cells(i, 1).Resize(1, 4).Value = Array(ws.Name, rng.Address, rng.Value, rng.Comment.Text)
Next
End If
Set commrange = Nothing
Next
newWs.Cells.WrapText = False
Application.ScreenUpdating = True
End Sub
I am writing a VBA script in Excel which needs to add a table of contents to a pre-existing word document in a specific location.
I have a word document with the following text somewhere in it: [contents_table_placeholder]
I want to find the text [contents_table_placeholder] and replace it with a word document automatic contents table.
However, I am struggling to get the table of contents to appear anywhere other than at the start of the document. My initial approach was to do a find and replace (replacing [contents_table_placeholder] with an empty string). I thought this would place the cursor in the correct place to then add the contents table but unfortunately this method doesn't work.
Sub createContentsPage()
Dim objWord As Word.Application
Dim inputDoc As Word.Document
Dim rngWord As Word.Range
Set objWord = New Word.Application
With objWord
.Visible = True
Set inputDoc = .Documents.Open( _
Filename:="C:\test.docx", _
ReadOnly:=False)
End With
With inputDoc.Content.Find
.Text = "[contents_table_placeholder]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.ExecuteReplace:=wdReplaceOne
End With
With inputDoc
Set rngWord = .Range(Start:=0, End:=0)
.TablesOfContents.Add _
Range:=rngWord, _
UseFields:=True, _
UseHeadingStyles:=True, _
LowerHeadingLevel:=2, _
UpperHeadingLevel:=1
End With
Set objWord = Nothing
Set inputDoc = Nothing
Set rngWord = Nothing
End Sub
After other attempts failed, I came up with the following work-around solution which involves creating the table of contents at the top of the document first and then cutting and pasting into the desired location.
Sub createContentsPage()
Dim objWord As Word.Application
Dim inputDoc As Word.Document
Dim rngWord As Word.Range
Set objWord = New Word.Application
With objWord
.Visible = True
Set inputDoc = .Documents.Open( _
Filename:="C:\test.docx", _
ReadOnly:=False)
End With
'Create table of contents at top of document
With inputDoc
Set rngWord = .Range(Start:=0, End:=0)
.TablesOfContents.Add _
Range:=rngWord, _
UseFields:=True, _
UseHeadingStyles:=True, _
LowerHeadingLevel:=2, _
UpperHeadingLevel:=1
End With
'Scroll to top of document
objWord.Selection.HomeKey Unit:=wdStory
'Select contents table
objWord.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
'Cut contents table
objWord.Selection.Cut
'Find placeholder and delete (cursor will remain at place holder)
With inputDoc.Content.Find
.Text = "[contents_table_placeholder]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.ExecuteReplace:=wdReplaceOne
End With
'Insert new line
objWord.Selection.TypeParagraph
'Paste contents table
objWord.Selection.PasteAndFormat (wdFormatOriginalFormatting)
inputDoc.Save
inputDoc.Close
Set objWord = Nothing
Set inputDoc = Nothing
Set rngWord = Nothing
End Sub
I am trying to run this VBA in an excel file. The first part of this code allows me to select a file and open it. I now want to have the code search the file and format the words I ask it to. I have written this code in Word before and am now just having trouble getting it into excel. Is there a line such as "withwdapp" that tells the excel vba to perform the next set of steps in Word?
Sub Find_Key_Words()
'Open an existing Word Document from Excel
Dim FileToOpen
Dim appwd As Object
ChDrive "C:\"
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to import", _
FileFilter:="Word Files *.docx (*.docx),")
If FileToOpen = False Then
MsgBox "No file specified.", vbExclamation, "Error"
Exit Sub
Else
Set appwd = CreateObject("Word.Application")
appwd.Visible = True
appwd.Documents.Open Filename:=FileToOpen
End If
Dim objWord As Object, objDoc As Object, Rng As Object
Dim MyAr() As String, strToFind As String
Dim i As Long
'This holds search words
strToFind = "w1,w2, w3, w4"
'Create an array of text to be found
MyAr = Split(strToFind, ",")
Set objWord = CreateObject("Word.Application")
'Open the relevant word document : CAN THIS BE DELETED?
Set objDoc = objWord.Documents.Open("C:\Sample.docx")
objWord.Visible = True
Set Rng = objWord.Selection
'Loop through the array to get the seacrh text
For i = LBound(MyAr) To UBound(MyAr)
With Rng.Find
.ClearFormatting
.Text = MyAr(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Execute
Set Rng = objWord.Selection
'Change the attributes
Do Until .Found = False
With Rng.Font
.Name = "Times New Roman"
.Size = 20
.Bold = True
.Color = RGB(200, 200, 0)
End With
Rng.Find.Execute
Loop
End With
Next i
End Sub
Change your code to this.
Const wdFindContinue = 1
Sub FnFindAndFormat()
Dim FileToOpen
Dim objWord As Object, objDoc As Object, Rng As Object
Dim MyAr() As String, strToFind As String
Dim i As Long
'~~> This holds your search words
strToFind = "deal,contract,sign,award"
'~~> Create an array of text to be found
MyAr = Split(strToFind, ",")
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to import", _
FileFilter:="Word Files *.docx (*.docx),")
If FileToOpen = False Then Exit Sub
Set objWord = CreateObject("Word.Application")
'~~> Open the relevant word document
Set objDoc = objWord.Documents.Open(FileToOpen)
objWord.Visible = True
Set Rng = objWord.Selection
'~~> Loop through the array to get the seacrh text
For i = LBound(MyAr) To UBound(MyAr)
With Rng.Find
.ClearFormatting
.Text = MyAr(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Execute
Set Rng = objWord.Selection
'~~> Change the attributes
Do Until .Found = False
With Rng.Font
.Name = "Times New Roman"
.Size = 20
.Bold = True
.Color = RGB(200, 200, 0)
End With
Rng.Find.Execute
Loop
End With
Next i
End Sub