Export comments from a PowerPoint presentation in a table of a Word document - vba

My intention is to use a VBA code to extract the comments from a PowerPoint document and paste the information in a table in Word.
I started to build a code that works on Word and I tried to adapt in to work with PowerPoint. Unfortunately I run in some errors like Error 07 memory issue, while the code works perfectly to extract comments form a word document...
I am lost and do not know what to do...
Is there an expert who could help me verifying the code? I made notes in the code to make it easy to read.
PS: In PowerPoint VBA Editor, I did enabled the reference for Word.
Sub Tansfer_PPT_comments_in_WordDoc()
Dim n As Long
Dim nCount As Long
Dim ppt As Presentation
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim wdtable As Table
Set ppt = ActivePresentation
nCount = ActivePresentation.Comments.Count
'Open a Word document
On Error Resume Next
Set wdapp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdapp = CreateObject("Word.Application")
End If
On Error GoTo 0
'Create word page with landscape orientation
Set wddoc = Documents.Add
wddoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 5-column table
With wddoc
.Content = ""
Set wdtable = .Tables.Add _
(Range:=Selection.Range, _
Numrows:=nCount + 1, _
NumColumns:=5)
End With
'DOCUMENT FORMATTING
'Define Normal and Header style
With wddoc.Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With wddoc.Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Format table
With wdtable
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns(1).PreferredWidth = 2
.Columns(2).PreferredWidth = 20
.Columns(3).PreferredWidth = 40
.Columns(4).PreferredWidth = 8
.Columns(5).PreferredWidth = 40
.Rows(1).HeadingFormat = True
.Columns(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Rows(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Font.ColorIndex = wdDarkBlue
Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColor = wdColorAutomatic
Selection.Shading.BackgroundPatternColor = -603937025
End With
'Add table borders
With wdtable.Borders
.InsideLineStyle = Options.DefaultBorderLineStyle
.InsideLineWidth = Options.DefaultBorderLineWidth
.InsideColor = Options.DefaultBorderColor
.OutsideLineStyle = Options.DefaultBorderLineStyle
.OutsideLineWidth = Options.DefaultBorderLineWidth
.OutsideColor = Options.DefaultBorderColor
End With
'DOCUMENT CONTENT
'Define table headings names
With wdtable.Rows(1)
.Range.Font.Bold = True
.Cells(1).Range.Text = "Page"
.Cells(2).Range.Text = "Comment scope"
.Cells(3).Range.Text = "Comment text"
.Cells(4).Range.Text = "Author"
.Cells(5).Range.Text = "Parexel response"
End With
'Insert information from the comments in ppt into the wddoc table
For n = 1 To nCount
With wdtable.Rows(n + 1)
'Page number
.Cells(1).Range.Text = _
ppt.Comments(n).Scope.Information(wdActiveEndPageNumber)
'The text marked by the comment
.Cells(2).Range.Text = ppt.Comments(n).Scope
'The comment itself
.Cells(3).Range.Text = ppt.Comments(n).Range.Text
'The comment author
.Cells(4).Range.Text = ppt.Comments(n).Author
End With
Next n
ScreenUpdating = True
Application.ScreenRefresh
wddoc.Activate
Set ppt = Nothing
Set wddoc = Nothing
Set wdtable = Nothing
End Sub

Your code will fail at:
ActivePresentation.Comments.Count
since Comments are not a Presentation property. And, once you get over that hurdle, your code will fail at:
.Scope.Information(wdActiveEndPageNumber)
since PowerPoint Comments don't have a scope property and, even if they did, '.Information(wdActiveEndPageNumber)' refers to a Word constant, not a PowerPoint one.
You can't simply take VBA methods, properties, and constants that apply to one application and assume they apply to another in the same way. You need to develop your PowerPoint code using valid PowerPoint methods, properties, and constants.
For some code to get you started on the right tack, see: http://www.pptfaq.com/FAQ00900_Export_comments_to_a_text_file_-PowerPoint_2002_and_later-.htm

Related

VBA | Word <--> Table Column Alignment

got a problem with the right alignment from columns in a word document.
I'm creating a word document with a table from one of our systems. The first time creating the table and selecting the columns for alignment will work without problems. If the user now creates a new document, overwriting the old one, it will crash. If the new word document is created, without overwriting an old one, no errors occur.
So the combination out of overwriting an existing document, there aren't any word processes running, and selecting columns for right alignment will crash. This is how I try to align the columns.
objTable.Columns(4).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
objTable.Columns(5).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
objTable.Columns(6).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
Does anyone have an idea how to fix this?
Thanks
€dit:
We have software, where a user can create a Word document. The word document loads a Word Template, in which a bookmark marks the location for creating the table. Before the table is created, the new document from the template will be saved on a network path. If there is already a document from that template, it should be overwritten. After saving the document for the first time and giving the right name, my method creates the table and fills it with content. The creating part will crash as soon as my method tries to align the columns(alignment-part in the code above) if there was a document created before. I took a look at the task manager there were no running word processes left after the first run. If a new word document is created, without overwriting an existing one, there are no problems with the alignment. So I guess the combination of overwriting an existing document and the alignment is responsible for the error.
€dit2 - My Code (I removed unneccessary lines of code like variable declaration):
'That is kind of strange, because even though it should be nothing it skipped that part - But if it tries to use the existing word instance - it crashes with the 462 - remote-server-computer is not available.
If app is Nothing Then
Set app = New Word.Application
Exit Function
End If
Set document = app.Documents.Add(Template:=Template, NewTemplate:=False, DocumentType:=0)
Dim settings As settings
settings = exportWord (document,...)
Private Function exportWord (oDoc As Word.Document, ...) As settings
On Error GoTo Err_WordExport
Dim sets As settings
With sets
.export = False
End With
exportWord = sets
Dim objRange As Word.Range
Dim objTable As Word.Table
With oDoc
Set objRange = .Bookmarks("tbl").Range
.Tables.Add objRange, positionen.Count + 1, 6
Set objTable = .Bookmarks("tbl").Range.Tables(1)
End With
With objTable
With .Rows(1)
.Cells(1).Range.Text = ""
.Cells(2).Range.Text = ""
.Cells(3).Range.Text = ""
.Cells(4).Range.Text = ""
.Cells(5).Range.Text = ""
.Cells(6).Range.Text = ""
.Cells(1).Range.Font.Bold = True
.Cells(2).Range.Font.Bold = True
.Cells(3).Range.Font.Bold = True
.Cells(4).Range.Font.Bold = True
.Cells(5).Range.Font.Bold = True
.Cells(6).Range.Font.Bold = True
End With
End With
Dim i As Long
i = 2
For Each ItemPos In Positionen
'fill the content
Next ItemPos
With objTable.Rows(1).Borders(wdBorderBottom)
.Visible = True
.LineStyle = wdLineStyleDouble
End With
objTable.Columns(4).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
objTable.Columns(5).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
objTable.Columns(6).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
objTable.Columns.AutoFit
oDoc.SaveAs2 pathToSave
With sets
.export = True
.PathToFile = pathToSave
End With
exportWord = sets
Set objTable = Nothing
End Function
You can avoid selecting the columns by looping through the cells. You can also simplify your code as below:
Set objTable = oDoc.Tables.Add(oDoc.Bookmarks("tbl").Range, Positionen.Count + 1, 6)
With objTable
Dim wdCell As Word.Cell
With .Rows(1).Borders(wdBorderBottom)
.Visible = True
.LineStyle = wdLineStyleDouble
End With
For Each wdCell In .Rows(1).Cells
With wdCell.Range
.Text = ""
.Font.Bold = True
End With
Next wdCell
Dim colIndex As Long
For colIndex = 4 To 6
For Each wdCell In .Columns(colIndex).Cells
wdCell.Range.ParagraphFormat.Alignment = wdAlignParagraphRight
Next wdCell
Next colIndex
End With
You can refine this even further simply by adding a 2 row table into the template with the formatting already applied. Then all you need is:
Set objTable = oDoc.Bookmarks("tbl").Range.Tables(1)
Dim i As Long
For i = 1 To positionen - 1
objTable.Rows.Add
Next i

Delete last section in Word VBA without the previous heading getting overwritten

I have the following code that I found when googleing on the problem. The problem with this code is that it overwrites the next-to-last section header (and footer though I only need the header preserved) to that of the last section, which is the default (strange) behavior of Word.
Is there a workaround to this in VBA?
Here is the code that has the inherent fault:
Sub DeleteLastSection()
'Deletes last section of a document including
'the section break
Dim doc As Document
Dim rng As Range
Dim ctr As Integer
Set doc = ActiveDocument
ctr = doc.Sections.Count
Set rng = doc.Sections(ctr).Range
Dim myheader As HeaderFooter
If ctr > 1 Then
With rng
.Select
.MoveStart Unit:=wdCharacter, Count:=-1
.Delete
End With
End If
End Sub
Note: The entire range of the last section is being deleted by the code and that is the required behavior. The inherent problem in the default behavior of Word is what I needed a workaround for in VBA code. One can found complex manual procedures to avoid it, but I needed a simple approach in code.
The problem here lies in the fact that the section break carries the section information. If you delete it, the last section becomes part of the section before. The trick I use below is to create a continuous section break instead of a page break, and then do all the rest:
Sub DeleteLastSection()
'Deletes last section of a document including
'the section break
Dim doc As Document
Dim rng As Range
Dim NewEndOfDocument As Range
Dim ctr As Integer
Set doc = ActiveDocument
ctr = doc.Sections.Count
Set rng = doc.Sections(ctr).Range
If ctr > 1 Then
' Create a section break at the end of the second to last section
Set NewEndOfDocument = doc.Sections(ctr - 1).Range
NewEndOfDocument.EndOf wdSection, wdMove
doc.Sections.Add NewEndOfDocument, wdSectionContinuous
With rng
.Select
.MoveStart Unit:=wdCharacter, Count:=-1
.Delete
End With
End If
End Sub
Ordinarily, deleting a Section break causes the Section preceding the break to assume the page layout of the following Section. The following macro works the other way, across multiple (selected) Section breaks. All common page layout issues (margins, page orientation, text columns, headers & footers) are addressed. As you can see by studying the code, it's no trivial task to do all these things.
Sub MergeSections()
Application.ScreenUpdating = False
Dim sPageHght As Single, sPageWdth As Single
Dim sHeaderDist As Single, sFooterDist As Single
Dim sTMargin As Single, sBMargin As Single
Dim sLMargin As Single, sRMargin As Single
Dim sGutter As Single, sGutterPos As Single
Dim lPaperSize As Long, lGutterStyle As Long
Dim lMirrorMargins As Long, lVerticalAlignment As Long
Dim lScnStart As Long, lScnDir As Long
Dim lOddEvenHdFt As Long, lDiffFirstHdFt As Long
Dim bTwoPagesOnOne As Boolean, bBkFldPrnt As Boolean
Dim bBkFldPrnShts As Boolean, bBkFldRevPrnt As Boolean
Dim lOrientation As Long, oHdFt As HeaderFooter
Dim Sctn1 As Section, Sctn2 As Section
With Selection
If .Sections.Count = 1 Then
MsgBox "Selection does not span a Section break", vbExclamation
Exit Sub
End If
Set Sctn1 = .Sections.First: Set Sctn2 = .Sections.Last
With Sctn1.PageSetup
lPaperSize = .PaperSize
lGutterStyle = .GutterStyle
lOrientation = .Orientation
lMirrorMargins = .MirrorMargins
lScnStart = .SectionStart
lScnDir = .SectionDirection
lOddEvenHdFt = .OddAndEvenPagesHeaderFooter
lDiffFirstHdFt = .DifferentFirstPageHeaderFooter
lVerticalAlignment = .VerticalAlignment
sPageHght = .PageHeight
sPageWdth = .PageWidth
sTMargin = .TopMargin
sBMargin = .BottomMargin
sLMargin = .LeftMargin
sRMargin = .RightMargin
sGutter = .Gutter
sGutterPos = .GutterPos
sHeaderDist = .HeaderDistance
sFooterDist = .FooterDistance
bTwoPagesOnOne = .TwoPagesOnOne
bBkFldPrnt = .BookFoldPrinting
bBkFldPrnShts = .BookFoldPrintingSheets
bBkFldRevPrnt = .BookFoldRevPrinting
End With
With Sctn2.PageSetup
.GutterStyle = lGutterStyle
.MirrorMargins = lMirrorMargins
.SectionStart = lScnStart
.SectionDirection = lScnDir
.OddAndEvenPagesHeaderFooter = lOddEvenHdFt
.DifferentFirstPageHeaderFooter = lDiffFirstHdFt
.VerticalAlignment = lVerticalAlignment
.PageHeight = sPageHght
.PageWidth = sPageWdth
.TopMargin = sTMargin
.BottomMargin = sBMargin
.LeftMargin = sLMargin
.RightMargin = sRMargin
.Gutter = sGutter
.GutterPos = sGutterPos
.HeaderDistance = sHeaderDist
.FooterDistance = sFooterDist
.TwoPagesOnOne = bTwoPagesOnOne
.BookFoldPrinting = bBkFldPrnt
.BookFoldPrintingSheets = bBkFldPrnShts
.BookFoldRevPrinting = bBkFldRevPrnt
.PaperSize = lPaperSize
.Orientation = lOrientation
End With
With Sctn2
For Each oHdFt In .Footers
oHdFt.LinkToPrevious = Sctn1.Footers(oHdFt.Index).LinkToPrevious
If oHdFt.LinkToPrevious = False Then
Sctn1.Headers(oHdFt.Index).Range.Copy
oHdFt.Range.Paste
End If
Next
For Each oHdFt In .Headers
oHdFt.LinkToPrevious = Sctn1.Headers(oHdFt.Index).LinkToPrevious
If oHdFt.LinkToPrevious = False Then
Sctn1.Headers(oHdFt.Index).Range.Copy
oHdFt.Range.Paste
End If
Next
End With
While .Sections.Count > 1
.Sections.First.Range.Characters.Last.Delete
Wend
Set Sctn1 = Nothing: Set Sctn2 = Nothing
End With
Application.ScreenUpdating = True
End Sub
Looking more into this on my own (I had to solve the issue in short order and could not wait), I came to the same conclusion as was noted in the comment by #CindyMeister that when deleting the last "section break" in actual fact the next-to-last section is being deleted, and what data and formatting heretofore belonged to the last section is apparently inherited by the new last section (i.e. the earlier next-to-last section). But in reality the last section remained and only the section break was deleted, so what was deleted was the next-to-last section (and the actual pages from the last section).
I found that the LinkToPrevious property of the HeaderFooter object allows a simplistic approach to "inherit" the settings from the previous section.
So by adding a few lines to set this property to true in each instance and then change it back to false, I can get the required behavior of the next-to-last section remaining the same as before.
(Please note that it worked for me because I simply had different text in the primary header, and did not have special formatting and else. But I suspect that based on the workings of the LinkToPrevious property this is a panacea. Please comment if otherwise.)
These are the lines to set the property:
for each hf in .Sections(1).Headers
hf.LinkToPrevious = True
hf.LinkToPrevious = False
next
for each hf in .Sections(1).Footers
hf.LinkToPrevious = True
hf.LinkToPrevious = False
next
The full working code for progeny:
Sub DeleteLastSection()
'Deletes last section of a document including
'the section break
Dim doc As Document
Dim rng As Range
Dim ctr As Integer
Set doc = ActiveDocument
ctr = doc.Sections.Count
Set rng = doc.Sections(ctr).Range
Dim myheader As HeaderFooter
If ctr > 1 Then
With rng
'Added lines to "inherit" the settings from the next-to-last section
for each hf in .Sections(1).Headers
hf.LinkToPrevious = True
hf.LinkToPrevious = False
next
for each hf in .Sections(1).Footers
hf.LinkToPrevious = True
hf.LinkToPrevious = False
next
.Select
.MoveStart Unit:=wdCharacter, Count:=-1
.Delete
End With
End If
End Sub
Deleting the last section of a word document is not a trivial task.
Things you might have to do if items are different between the 'next to last' and 'last' section of a document.
Ensure that in the last section any 'linktoprevious' in a header or footer is set to to false
Copy all headers and footers from the next to last section to the last section
Copy the relevant page format items of the next to last section to the last section (paper size, orientation, margins etc)
Get the range for the last section in the document. Move the end of the range backward until the ascii value is >=32.
Then you can safely delete the adjusted range from your document without any nasty side effects
This is the code I just created that works well:
Sub DeleteLastPage()
Dim pgSetUp As PageSetup
Dim iSect As Integer
iSect = ActiveDocument.Sections.Count - 1
Set pgSetUp = ActiveDocument.Sections(iSect).PageSetup
With ActiveDocument.Sections.Last.PageSetup
.LineNumbering.Active = pgSetUp.LineNumbering.Active
.Orientation = pgSetUp.Orientation
.TopMargin = pgSetUp.TopMargin
.BottomMargin = pgSetUp.BottomMargin
.LeftMargin = pgSetUp.LeftMargin
.RightMargin = pgSetUp.RightMargin
.Gutter = pgSetUp.Gutter
.HeaderDistance = pgSetUp.HeaderDistance
.FooterDistance = pgSetUp.FooterDistance
.PageWidth = pgSetUp.PageWidth
.PageHeight = pgSetUp.PageHeight
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = pgSetUp.OddAndEvenPagesHeaderFooter
.DifferentFirstPageHeaderFooter = pgSetUp.DifferentFirstPageHeaderFooter
.VerticalAlignment = wdAlignVerticalTop
End With
With ActiveDocument.Sections.Last.Headers(wdHeaderFooterPrimary)
.LinkToPrevious = true
End With
With ActiveDocument.Sections.Last.Footers(wdHeaderFooterPrimary)
.LinkToPrevious = true
End With
ActiveDocument.Sections.Last.Range.Characters.Delete
Selection.EndKey Unit:=wdStory
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter,Count:=1
End Sub

Excel to Word (Text won't Justify) VBA

So to summarize things, I am creating a word document and pasting an excel table into the Word document. The only problem I'm facing now is that the texts in the Word document is aligned left but I want it Justified. However, no matter what I do I can't seem to get it to justify unless I manually do it on Word.
Please find below my code less all the non-relevant stuff. I'm a VBA noob so how I've been doing it is just copy pasting and trying to adapt it to what I need. So far everything works except the justifying part.
Dim obj As Object
Set obj = GetObject(, "Word.Application")
If obj Is Nothing Then
Set obj = CreateObject("Word.Application")
End If
obj.Visible = True
Set objDoc = obj.Documents.Add
a = Sheets("Print").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Print").Range("A1:F" & a).Copy
objDoc.Range.PasteExcelTable False, False, True
objDoc.Activate
objDoc.Tables(1).AutoFitBehavior wdAutoFitContent
Application.CutCopyMode = False
On Error GoTo 0
With objDoc.Tables(1)
.PreferredWidth = 505
End With
With objDoc.PageSetup
.TopMargin = Application.InchesToPoints(0.71)
.BottomMargin = Application.InchesToPoints(0.71)
.LeftMargin = Application.InchesToPoints(0.71)
.RightMargin = Application.InchesToPoints(0.71)
End With
With objDoc
.Range.ParagraphFormat.LineSpacingRule = wdLineSpace1pt5
'set paragraph spacing after to 0
.Range.ParagraphFormat.SpaceAfter = 10
.Range.ParagraphFormat.Alignment = wdAlignParagraphJustify
End With
Sheets("DCN Inputs").Select
End Sub
The problem is that you use the Word enumeration value wdAlignParagraphJustify but you don't have a reference to the Word object library. Excel VBA doesn't recognize this member of the Word object model without a specific reference (Tools/References).
If you want to use late-binding, as you have otherwise throughout your code, then you need to substitute the numerical value of the enumeration, which in this case is 3. For example:
objDoc.Range.PasteExcelTable False, False, True
objDoc.Activate
Set objTable = objDoc.Tables(1)
With objTable
.AutoFitBehavior wdAutoFitContent
.PreferredWidth = 505
.Range.ParagraphFormat.Alignment = 3 'wdAlignParagraphJustify
End With
Application.CutCopyMode = False

Making Certain Text Bold In Excel VBA

I am exporting an excel table into word using VBA. The word document has one bookmark. The code is such that first it writes the TYPE as the heading and then write all the description under that TYPE. I want the headings to be bold and formatted. I have the following code but it does not work. If anyone could suggest something.
If Dir(strPath & "\" & strFileName) <> "" Then
'Word Document open
On Error Resume Next
Set objWDApp = GetObject(, "Word.Application")
If objWDApp Is Nothing Then Set objWDApp = CreateObject("Word.Application")
With objWDApp
.Visible = True 'Or True, if Word is to be indicated
.Documents.Open (strPath & "\" & strFileName)
Set objRng = objWDApp.ActiveDocument.Bookmarks("Bookmark").Range
.Styles.Add ("Heading")
.Styles.Add ("Text")
With .Styles("Heading").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = True
End With
With .Styles("Text").Font
.Name = "Arial"
.Size = 10
.Bold = False
.Underline = False
End With
End With
On Error GoTo 0
i = Start_Cell
idx(1) = i
n = 2
Do ' Search for first empty cell in the table
i = i + 1
If i > Start_Cell + 1 And Cells(i, QB_Type).Value = Cells(i - 1, QB_Type) Then GoTo Loop1
idx(n) = i
n = n + 1
Loop1:
Loop Until IsEmpty(Cells(i + 1, QB_Type).Value)
idxEnd = i
idx(n) = 9999
i = Start_Cell
n = 1
Do
If i = idx(n) Then
strTMP = vbNewLine & vbNewLine & Cells(idx(n), QB_Type).Value & vbNewLine
With objWDApp
'.Selection.Font.Bold = True 'Type Bold (Doesnt Functions!?)
.Selection.Styles ("Heading") 'I tried this as well but not functioning...gives an error here that object does not support this property
WriteToWord objRng, strTMP 'Text written
End With
n = n + 1
End If
strTMP = vbNewLine & Cells(i, QB_Description).Value & vbNewLine
With objWDApp
' .Selection.Font.Bold = False 'Description Not bold (Not functioning!?)
.Selection.Styles("Text") 'This is also not functioning
WriteToWord objRng, strTMP 'Text written
End With
i = i + 1 'Arbeitspunktzähler erhöhen
Loop Until i > idxEnd
Public Sub WriteToWord(objRng, text)
With objRng
.InsertAfter text
End With
End Sub
Try .Selection.Style.Name = "Heading" from here
Edit 2
The following code works as expected. You will need to modify it to fit your needs. I successfully added and then bolded text to an existing word document.
Option Explicit
Public Sub Test()
' Add a reference to Microsoft Word x.0 Object Library for early binding and syntax support
Dim w As Word.Application
If (w Is Nothing) Then Set w = New Word.Application
Dim item As Word.Document, doc As Word.Document
' If the document is already open, just get a reference to it
For Each item In w.Documents
If (item.FullName = "C:\Path\To\Test.docx") Then
Set doc = item
Exit For
End If
Next
' Else, open the document
If (doc Is Nothing) Then Set doc = w.Documents.Open("C:\Path\To\Test.docx")
' Force change Word's default read-only/protected view
doc.ActiveWindow.View = wdNormalView
' Delete the preexisting style to avoid an error of duplicate entry next time this is run
' Could also check if the style exists by iterating through all styles. Whichever method works for you
doc.Styles.item("MyStyle").Delete
doc.Styles.Add "MyStyle"
With doc.Styles("MyStyle").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = wdUnderlineSingle
End With
' Do your logic to put text where you need it
doc.Range.InsertAfter "This is another Heading"
' Now find that same text you just added to the document, and bold it.
With doc.Content.Find
.Text = "This is another Heading"
.Execute
If (.Found) Then .Parent.Bold = True
End With
' Make sure to dispose of the objects. This can cause issues when the macro gets out mid way, causing a file lock on the document
doc.Close
Set doc = Nothing
w.Quit
Set w = Nothing
End Sub
By adding a reference to the object library, you can get intellisense support and compilation errors. It would help you determine earlier in development that Styles is not a valid property off the Word.Application object.

Find all Heading 1 Text and Put it into an Array

I am using a VBA Macro to render all the "Heading 1" style text from a word document.
It is working fine but taking huge time depends on the content of word doc.
I am looping each paragraph to check for "Heading 1" style and render the Text into an array.
I wonder if there is an alternative approach to simply find "Heading 1" style and store the text in array which would greatly reduce the execution time.
Below my Macro program and I would appreciate any expert thoughts regarding the above mentioned.
Sub ImportWordHeadings()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim sHeader(50) As String
Dim Head1counter As Integer
Dim arrcount As Long
Dim mHeading As String
On Error Resume Next
wdFileName = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
p = 1
RetCount = 0
parg = wdDoc.Paragraphs.Count
For Head1counter = 1 To parg
If wdDoc.Paragraphs(Head1counter).Range.Style = "Heading 1" Then
sHeader(p) = wdDoc.Paragraphs(Head1counter).Range.Text
p = p + 1
Else
p = p
End If
Next Head1counter
For arrcount = RetCount + 1 To UBound(sHeader)
If sHeader(arrcount) <> "" Then
Debug.Print sHeader(arrcount)
RetCount = arrcount
Exit For
Else
RetCount = RetCount
End If
Next arrcount
Set wdDoc = Nothing
End Sub
You can use the Find method to search for all of the headings, very similar to what I did over here on Code Review.
Set doc = ActiveDocument
Set currentRange = doc.Range 'start with the whole doc as the current range
With currentRange.Find
.Forward = True 'move forward only
.Style = wdStyleHeading1 'the type of style to find
.Execute 'update currentRange to the first found instance
dim p as long
p = 0
Do While .Found
sHeader(p) = currentRange.Text
' update currentRange to next found instance
.Execute
p = p + 1
Loop
End With