Excel VBA not consistently formatting the table margins - vba

I have an excel form that will open up ms word and go to the sixth table and adjust the cell margins. I want the left and right cell margins to be 0.08 for the entire table.
It works perfectly the first time the form is run, but the second time and after it won't do it. Here is my code. Can anyone tell me why this would happen?
Public Sub Table()
Dim wrdApp
Dim wrdDoc
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
Set wrdDoc = wrdApp.Documents.Open("\\FileLocation")
With wrdDoc
'Goes to 6th table and selects it
wrdApp.Selection.Goto wdGoToPage, wdGoToAbsolute, 1
wrdApp.Selection.Goto What:=wdGoToTable, Which:=GoToNext
wrdApp.Selection.Goto What:=wdGoToTable, Which:=GoToNext
wrdApp.Selection.Goto What:=wdGoToTable, Which:=GoToNext
wrdApp.Selection.Goto What:=wdGoToTable, Which:=GoToNext
wrdApp.Selection.Goto What:=wdGoToTable, Which:=GoToNext
wrdApp.Selection.Goto What:=wdGoToTable, Which:=GoToNext
wrdApp.Selection.Tables(1).Select
With wrdApp.Selection.Tables(1)
.TopPadding = InchesToPoints(0)
.BottomPadding = InchesToPoints(0)
.LeftPadding = InchesToPoints(0.08)
.RightPadding = InchesToPoints(0.08)
.Spacing = 0
.AllowPageBreaks = True
.AllowAutoFit = True
End With
End Sub

Why are you using wrdApp.Selection.Goto What:=wdGoToTable, Which:=GoToNext? Why not Set wrdTbl = wrdDoc.Tables(6) and work with that? All that code may be referring to another table?
Try something like this:
Private Sub Sample()
Dim wrdApp As Object, wrdDoc As Object, wrdTbl As Object
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
Set wrdDoc = wrdApp.Documents.Open("\\FileLocation")
Set wrdTbl = wrdDoc.Tables(6)
With wrdTbl
.TopPadding = wrdApp.InchesToPoints(0)
.BottomPadding = wrdApp.InchesToPoints(0)
.LeftPadding = wrdApp.InchesToPoints(0.08)
.RightPadding = wrdApp.InchesToPoints(0.08)
.Spacing = 0
.AllowPageBreaks = True
.AllowAutoFit = True
End With
End Sub

Related

How to format selected text?

I am trying to format selected text in Outlook 2010.
I recorded a macro that works for Word.
My Outlook code fails on the second line before I get to the working Word code.
I have been using VBA for many years, almost entirely in Excel.
Option Explicit
Public Sub UseWord_Fmt()
' Wrapper
Dim Ins As Outlook.Inspector
Dim wDoc As Word.Document
Dim Word As Word.Application
Dim Selection As Word.Selection
Set Ins = Application.ActiveInspector
Set wDoc = Ins.WordEditor
Set Word = wDoc.Application
Set Selection = Word.Selection
'
'
' My code, generic so that I can later modify
'
'
Selection.HomeKey Unit:=wdStory
Selection.MoveDown Unit:=wdLine, Count:=4, Extend:=wdExtend
With Selection.ParagraphFormat
.LeftIndent = InchesToPoints(0)
.RightIndent = InchesToPoints(0)
.SpaceBefore = 6
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = InchesToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
End With
End Sub
Outlook does not understand InchesToPoints(0) When Converting a measurement from inches to points- simply use .LeftIndent = (0), or specify the Application Example Word.InchesToPoints(0)
Public Sub UseWord_Fmt()
' Wrapper
Dim Ins As Outlook.Inspector
Dim wDoc As Word.Document
Dim Word As Word.Application
Dim Selection As Word.Selection
Set Ins = Application.ActiveInspector
Set wDoc = Ins.WordEditor
Set Word = wDoc.Application
Set Selection = Word.Selection
'
'
' My code, generic so that I can later modify
'
'
Selection.HomeKey Unit:=wdStory
Selection.MoveDown Unit:=wdLine, Count:=4, Extend:=wdExtend
With Selection.ParagraphFormat
.LeftIndent = (0)
.RightIndent = (0)
.SpaceBefore = 6
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.pageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = (0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
End With
End Sub

Run-Time Error '462'

I am trying to run a macro from excel that will open up an existing word document, populate the fields from excel to word via content controls, and paste/format a table into the word document at a certain location. About 20% of the time, I'll get this Run Time Error 462 stating "The remote Server Machine Does Not Exist or is Unavailable". I will provide the code and the section where is usually gets stuck at as everything after works 100% of the time. Please help on this.
Public Sub Agreement()
With Sheets("Price List Table")
.ListObjects(1).Name = "Table1"
End With
Dim tbl As Excel.Range
Dim wrdApp
Dim wrdDoc
Dim WordTable As Word.Table
Dim c As Integer
Set tbl = ThisWorkbook.Worksheets(Sheet2.Name).ListObjects("Table1").Range
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = False
Set wrdDoc = wrdApp.Documents.Open("C:\Users\Documents\Example")
With wrdDoc
tbl.Copy
wrdApp.Selection.Find.Text = "This is the section for the table to be pasted below it."
wrdApp.Selection.Find.Execute
wrdApp.Selection.MoveDown Unit:=wdLine, Count:=5, Extend:=wdMove
wrdApp.Selection.PasteExcelTable False, False, False
Dim objTable As Object
For Each objTable In ActiveDocument.Tables ' (This is where the error occurs)
objTable.AutoFitBehavior (wdAutoFitWindow)
objTable.AllowAutoFit = True
Next
wrdApp.Selection.GoTo wdGoToPage, wdGoToAbsolute, 1
wrdApp.Selection.GoTo What:=wdGoToTable, Which:=GoToNext
wrdApp.Selection.GoTo What:=wdGoToTable, Which:=GoToNext
wrdApp.Selection.GoTo What:=wdGoToTable, Which:=GoToNext
wrdApp.Selection.Tables(1).Select
With wrdApp.Selection.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With wrdApp.Selection.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With wrdApp.Selection.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With wrdApp.Selection.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With wrdApp.Selection.Borders(wdBorderHorizontal)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With wrdApp.Selection.Borders(wdBorderVertical)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
wrdApp.Selection.Tables(1).Columns(3).Select
wrdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
wrdApp.Selection.Tables(1).Columns(4).Select
wrdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphRight

Excel VBA - Border issues converting to word

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 :

How to check orientation of each consecutive section?

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

VBA: Format MS Word text

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