Solved: Help Finding Style and Copy to Excel using Word Macros

[soldtoscienc]

Hello!

I'm looking for a way to find each instance of a style (such as heading 1, heading 2...) in a word document, and paste the results in a column in excel on a mac.

I work in video production, the word documents are scripts, and the styles are highlights in the script noting what is a shot, what is a graphic, where stock photography goes ect. to help the video editors. Styles seemed like the easiest way to highlight text and also be able to differentiate each type of text in a macro.

Once each style is copied in its own row in excel we have a way to export them to photoshop to batch process graphics, so that's the motivation. As of now we're copy/pasting each instance by hand.

I'm not a great coder, but was tasked with this job. So far I've made some sloppy arrays and never-ending loops that made 60 new excel sheets before I could stop it.

Any help would be greatly appreciated! Thank you!

[soldtoscienc]

Here is an example of a piece of code that finds the first example of style "heading 1" and pastes it to excel.

One problem I've had so far is when I tried to add a Do.. Loop, I wasn't able to figure out a way to tell the loop it reached the end of the document, so it looped forever.

Also, I'm pretty sure I'll want to use an array for each style type, and then copy to excel. Still working on that.


Sub type_make_heading()
'
' type_make_heading Macro
'
'

Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 1")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Copy




Dim oExcel As Object
Dim oBook As Object
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add


oBook.Worksheets(1).Range("A1").Select
oBook.Worksheets(1).paste


End Sub

[geekgirlau]

Sub type_make_heading()
Dim oExcel As Object
Dim oBook As Object
Dim oRng As Object
Dim para As Paragraph
Dim strStyle As String
Dim l As Long


' use existing instance of Excel if possible
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")

If Err.Number <> 0 Then
Set oExcel = CreateObject("Excel.Application")
End If

' should use proper error handling here
On Error GoTo 0
Set oBook = oExcel.Workbooks.Add
Set oRng = oBook.Sheets(1).Range("A1")

strStyle = "Heading 2"

For Each para In ActiveDocument.Paragraphs
If para.Style = strStyle Then
oRng.Offset(l, 0).Formula = para.Range.Text
l = l + 1
End If
Next para

ExitHere:
On Error Resume Next
oExcel.Visible = True
oExcel.Activate

Set oRng = Nothing
Set oBook = Nothing
Set oExcel = Nothing
End Sub

[soldtoscienc]

Works beautifully! Thank you so much!