I am using userforms to transfer data into worksheet, then converting it to word document. I created bunch of tables to be fill in userform textboxes. Since some of the comments could be very long, I set those tables as wrap text and autofit row height. While some of the tables are fitting word page, some of them are going beyond of page and some of the borders are going below page without proper format.borders.
I deleted contents in the word tables, you can consider it full of text.
How could I fit those borders into word document without overflow to the other pages?
Sub TestingMacAndWin1()
Application.ScreenUpdating = False
Dim appWD As Object
Dim wddoc As Object
On Error Resume Next
Set appWD = GetObject(, "Word.application")
If Err = 429 Then
Set appWD = CreateObject("Word.application")
Err.Clear
End If
Set wddoc = appWD.Documents.Add
appWD.Visible = True
With appWD.ActiveDocument.PageSetup
.Orientation = 1
.Content.Style = .Styles("No Spacing")
.TopMargin = appWD.InchesToPoints(0.3)
.BottomMargin = appWD.InchesToPoints(0.3)
.LeftMargin = appWD.InchesToPoints(0.3)
.RightMargin = appWD.InchesToPoints(0.3)
.InsertBreak Type:=0
End With
Sheets("Sheet1").Range("B4").CurrentRegion.Copy
appWD.Selection.Paste
Sheets("C").Range("C6:F20").Copy
appWD.Selection.Paste
With appWD.Selection
.Collapse Direction:=0
.InsertBreak Type:=7
End With
For i = 1 To wddoc.Tables.Count - 1
wddoc.Tables(i).Select
wddoc.Tables(i).AutoFitBehavior wdAutoFitWindow
With wddoc.Tables(i).Range
.bordersall = True
.Font.Name = "Calibri"
End With
Next i
appWD.Activate
Application.ScreenUpdating = True
End Sub
Replace your appWD.Selection.Paste to appWD.Selection.PasteExcelTable False, True, False. It's work fine for me :
Sub TestingMacAndWin1()
Application.ScreenUpdating = False
Dim appWD As Object
Dim wddoc As Object
On Error Resume Next
Set appWD = GetObject(, "Word.application")
If Err = 429 Then
Set appWD = CreateObject("Word.application")
Err.Clear
End If
Set wddoc = appWD.Documents.Add
appWD.Visible = True
With appWD.ActiveDocument.PageSetup
.Orientation = 1
.Content.Style = .Styles("No Spacing")
.TopMargin = appWD.InchesToPoints(0.3)
.BottomMargin = appWD.InchesToPoints(0.3)
.LeftMargin = appWD.InchesToPoints(0.3)
.RightMargin = appWD.InchesToPoints(0.3)
.InsertBreak Type:=0
End With
Sheets("Sheet1").Range("a1").CurrentRegion.Copy
appWD.Selection.PasteExcelTable False, True, False
Sheets("Sheet1").Range("b1:F20").Copy
appWD.Selection.PasteExcelTable False, True, False
End Sub
Before :
After paste change :
Related
I am working on a macro that would plot through currently opened document sections one by one, check whether they are portrait or landscape, and set their margins (incl. header and footer) to given dimensions (which are different depending on the page orientation).
How do I detect the page orientation of each section and make it the current "selection" or put the cursor on its beginning, so the next line could set its margins and skip to the next section?
This is what I got so far:
Sub Margins()
Dim nOriginalPagination As Integer
Dim objSection As Section
Dim nPaperSize As Integer
Dim ContinueOn As Boolean
ContinueOn = False
nNumSects = ActiveDocument.Sections.Count
ActiveWindow.View.Type = wdPageView
If ActiveWindow.View.SeekView <> wdSeekMainDocument Then
ActiveWindow.View.SeekView = wdSeekMainDocument
End If
Selection.HomeKey wdStory, wdMove
For Each objSection In objDocument.Sections
iSecNum = Selection.Information(wdActiveEndSectionNumber)
With objSection.PageSetup
nPaperSize = PAPERLETTER
End With
Next
For Each objSection In objDocument.Sections
iSecNum = Selection.Information(wdActiveEndSectionNumber)
With objSection.PageSetup
'Set the margins, depending on the page orientation
If .Orientation = wdOrientPortrait Then
.TopMargin = CentimetersToPoints(2.23)
.BottomMargin = CentimetersToPoints(2.21)
.LeftMargin = CentimetersToPoints(3.17)
.RightMargin = CentimetersToPoints(3.17)
.HeaderDistance = CentimetersToPoints(0.96)
.FooterDistance = CentimetersToPoints(0.94)
Else
.TopMargin = CentimetersToPoints(3.17)
.BottomMargin = CentimetersToPoints(3.17)
.LeftMargin = CentimetersToPoints(2.21)
.RightMargin = CentimetersToPoints(2.23)
.HeaderDistance = CentimetersToPoints(1.9)
.FooterDistance = CentimetersToPoints(1.9)
End If
End With
Application.ScreenUpdating = True
Options.Pagination = nOriginalPagination
Selection.GoTo what:=wdGoToSection, Which:=wdGoToNext
Next
End Sub
Error says I am missing as object.
Your code has several issues:
undeclared variables
unnecessary use of the Selection object
ScreenUpdating being turned on without having been turned off
The line that is causing the error is:
For Each objSection In objDocument.Sections
This is because the undeclared variable objDocument is not set to anything.
The code you need is below:
Sub Margins()
Dim objDocument as Document
Dim objSection As Section
Application.ScreenUpdating = False
Set objDocument = ActiveDocument
For Each objSection In objDocument.Sections
With objSection.PageSetup
'Set the margins, depending on the page orientation
If .Orientation = wdOrientPortrait Then
.TopMargin = CentimetersToPoints(2.23)
.BottomMargin = CentimetersToPoints(2.21)
.LeftMargin = CentimetersToPoints(3.17)
.RightMargin = CentimetersToPoints(3.17)
.HeaderDistance = CentimetersToPoints(0.96)
.FooterDistance = CentimetersToPoints(0.94)
Else
.TopMargin = CentimetersToPoints(3.17)
.BottomMargin = CentimetersToPoints(3.17)
.LeftMargin = CentimetersToPoints(2.21)
.RightMargin = CentimetersToPoints(2.23)
.HeaderDistance = CentimetersToPoints(1.9)
.FooterDistance = CentimetersToPoints(1.9)
End If
End With
Next
Application.ScreenUpdating = True
End Sub
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
My goal is to write a sentence/paragraph with the ability to change font styles within the same sentence/paragraph. This is being done in Excel VBA and outputs in a word document (I'm sure you can tell).
Example: "Please see Table 1. Note Table 1 is assumed."
With the code below it seems to set the whole sentence to the last wdStyleTypeCharacter that was called out.
Dim appWord As Word.Application
Dim objDoc As Word.Document
Set appWord = New Word.Application
appWord.Visible = True
Set objDoc = appWord.Documents.Add
Set Normal = objDoc.Styles.Add(Name:="Normal", Type:=wdStyleTypeCharacter)
Set Bold = objDoc.Styles.Add(Name:="Bold", Type:=wdStyleTypeCharacter)
Set Italic = objDoc.Styles.Add(Name:="Italic", Type:=wdStyleTypeCharacter)
With objDoc
With .Styles(Normal)
.Font.Name = "Arial Narrow"
.Font.Size = 11
.Font.Italic = False
.Font.Bold = False
End With
With .Styles(Bold)
.Font.Name = "Arial Narrow"
.Font.Size = 11
.Font.Italic = False
.Font.Bold = True
End With
With .Styles(Italic)
.Font.Name = "Arial Narrow"
.Font.Size = 11
.Font.Italic = True
.Font.Bold = False
End With
.Content.InsertParagraphAfter
.Range.Style = .Styles(Normal)
.Content.InsertAfter "Please see "
.Range.Style = .Styles(Bold)
.Content.InsertAfter "Table 1"
.Range.Style = .Styles(Italic)
.Content.InsertAfter ". Note Table 1 is assumed."
.Content.InsertParagraphAfter
End with
objDoc.Close savechanges:=wdSaveChanges
appWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
End Sub
I'm not 100% sure why you have to you .selection the word.application but this solves my problem. If anyone could answer this that would be great just for my basic understanding (new to this).
Dim appWord As Word.Application
Dim objDoc As Word.Document
Set appWord = New Word.Application
appWord.Visible = True
Set objDoc = appWord.Documents.Add
With appWord.Selection
.Font.Name = "Arial Narrow"
.Font.Size = 11
.TypeText Text:="Please see "
.Font.Bold = wdToggle
.TypeText Text:="Table 1"
.Font.Bold = wdToggle
.Font.Italic = wdToggle
.TypeText Text:=". Note Table 1 is assumed."
End With
objDoc.Close savechanges:=wdSaveChanges
appWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
End Sub
Hope this can help someone else in the future.
I am trying to format text of multiple words. So far, the code below will only allow me to format the font of one word. What do I need to add / delete in order to have as many words as I input be formatted?
Cheers!
Sub FnFindAndFormat()
Dim objWord
Dim objDoc
Dim intParaCount
Dim objParagraph
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:\USERPATH")
objWord.Visible = True
intParaCount = objDoc.Paragraphs.Count
Set objParagraph = objDoc.Paragraphs(1).range
objParagraph.Find.Text = "deal"
Do
objParagraph.Find.Execute
If objParagraph.Find.Found Then
objParagraph.Font.Name = "Times New Roman"
objParagraph.Font.Size = 20
objParagraph.Font.Bold = True
objParagraph.Font.Color = RGB(200, 200, 0)
End If
Loop While objParagraph.Find.Found
End Sub
Let's say your word document looks like this
Since I am not sure whether you are doing this from Word-VBA or from some other application like say Excel-VBA so I am including both methods.
Now if you are doing this from Word-VBA then you do not need to LateBind with it. Use this simple code.
Option Explicit
Sub Sample()
Dim oDoc As Document
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, ",")
'~~> Open the relevant word document
Set oDoc = Documents.Open("C:\Sample.docx")
'~~> Loop through the array to get the seacrh text
For i = LBound(MyAr) To UBound(MyAr)
With Selection.Find
.ClearFormatting
.Text = MyAr(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Execute
'~~> Change the attributes
Do Until .Found = False
With Selection.Font
.Name = "Times New Roman"
.Size = 20
.Bold = True
.Color = RGB(200, 200, 0)
End With
Selection.Find.Execute
Loop
End With
Next i
End Sub
However if you are doing from say Excel-VBA then use this
Const wdFindContinue = 1
Sub FnFindAndFormat()
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, ",")
Set objWord = CreateObject("Word.Application")
'~~> Open the relevant word document
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
OUTPUT
Works like a charm for me:
Public Sub Find_some_text()
'setting objects
Dim objWord
Dim objDoc
Dim objSelection
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("H:\Test.docx")
'set visibility
objWord.Visible = True
'set array of words to format
words_list = Array("Findme_1", "Findme_2", "etc")
'formatting text
For Each w In words_list
Set Frange = objDoc.Range
Frange.Find.Text = w
Do
Frange.Find.Execute
If Frange.Find.Found Then
Frange.Font.Name = "Times New Roman"
Frange.Font.Size = 20
Frange.Font.Bold = True
Frange.Font.Color = RGB(200, 200, 0)
End If
Loop While Frange.Find.Found
Next
'de-set visibility
objWord.Visible = False
'saving (optional)
objDoc.Save
End Sub
This code:
For Each w In words_list
Set Frange = objDoc.Range
Frange.Find.Text = w
Do
Frange.Find.Execute
If Frange.Find.Found Then
Frange.Font.Name = "Times New Roman"
Frange.Font.Size = 20
Frange.Font.Bold = True
Frange.Font.Color = RGB(200, 200, 0)
End If
Loop While Frange.Find.Found
Next
is inefficient. Try:
With objDoc.Range.Find
.ClearFormatting
With .Replacement
.ClearFormatting
.Text = "^&"
With .Font
.Name = "Times New Roman"
.Size = 20
.Bold = True
.Color = RGB(200, 200, 0)
End With
End With
.Format = True
.Forward = True
.Wrap = 1 'wdFindContinue
For Each w In words_list
.Text = w
.Execute Replace:=2 'wdReplaceAll
Next
End With
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