Solved: Help searching document for Character Styles

[soldtoscienc]

Hello!

After geekgirlau did an amazing job of cracking the "copy paragraph styles to excel" nut,

vbaexpress.com/forum/showthread.php?t=42286

I realized that the actual scripts use custom character styles, not paragraph styles, because there are paragraphs that contain several different character styles.

For example, a paragraph will have a sentence highlighted in red to show a video shot, followed by a sentence with a vocabulary word highlighted in blue. The red highlight is a custom character style called "Activity Footage" and the blue highlight is a custom character style called "New Word".


Here's my question:

Using the "Activity Footage" style as an example, Is there a way to search each paragraph for character styles? Then copy sentences with the same style to excel?

Or would I have to search each word in the document for the "Activity Footage" style?

If I have to search each word, then I would have to figure out a way to put together sentences with the same style before copying them to excel. I wouldn't want to copy each word into a different cell in excel.


Apologies for the long post! Thanks!

[Frosty]

Everyone has their different styles... you could approach this in the same way that geekgirlau did (do a For...Each loop in each paragraph). There is even a sentences collection that you could use as a mid point between words and paragraphs. However, two problems:
1. The sentences collection is notoriously fickle.
2. You have to reconstitute the individual pieces before dumping them into Excel. And how do you tell the code to do that?

Forgetting VBA for a moment, you can perform a manual Find (CTRL+F) in a document, but rather than look for text... you can look for a style. Have you tried this? Have you tried recording a macro while doing this?

You already have sample code (in that other thread) where you take some text and dump it into an Excel column... now you just need a way to get the text.

Try the above (investigating the find object, and recording a macro to find it once). Then post that code (cleaned up as much as you can), and I think you'll find it very easy to modify into a loop.

[soldtoscienc]

Yes! The advanced find and replace did allow me to select whole sentences of the same style, and I was able to find two separate instances in the same paragraph. So it looks like that won't be an issue.

Although now I'm back where I started, where I'm not sure how to add a loop and then tell the document I've reached the end.

Could I combine this find into the code I have from geekgirlau?

Sub actfoot_test3()
'
' actfoot_test3 Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Activity Footage")
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.Find.Execute
Selection.Find.Execute
Selection.Find.Execute
End Sub

[Frosty]

Sure you can... I don't know how you've modified her code to do more than put "Heading 2" paragraph text into your excel document, but you could easily extract the data in much the same way. This would put the sentences in each cell below whatever you've already done above... I'm not sure where you want to place it, so this may not be the desired place to input it in the Excel sheet.. but this does the loop.

Note-- when you use ranges to perform searches, you don't have to establish all of the settings, just the ones different than a default search.

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

'set up the search
Dim rngSearch As Range
Set rngSearch = ActiveDocument.Content
With rngSearch.Find
.Style = "Activity Footage"
.Wrap = wdFindStop
.Format = True
'now execute until you don't find it... starting at the top of the document and stopping at the end
Do Until .Execute = False
oRng.Offset(l, 0).Formula = rngSearch.Text
l = l + 1
Loop
End With


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

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

[soldtoscienc]

Nice! Thanks! I haven't changed much except to start each column on A2, B2, ect. and when I copied the loop to add new styles I got rid of the open excel comment and had to add a l = 0 to reset the row count.

Here is the code in all it's final glory! Named frosty_geek in honor of the creators :beerchug: I only copied in 3 styles to keep it short, there are 17 styles in total.


One last question, How would I open an existing excel sheet on a mac? I'm used to the C: addresses from Windows.

For example I have this spreadsheet in Mac Harddrive > Users > Me > Documents > Work > 2012-05 Scripts

Thank you so much for all the help and tips! I'm sure to be back, and hopefully a little more educated!

Sub frosty_geek()
'
' frosty_geek Macro
'
'
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("A2")

'set up the search
Dim rngSearch As Range
Set rngSearch = ActiveDocument.Content
With rngSearch.Find
.Style = "Activity Footage"
.Wrap = wdFindStop
.Format = True
'now execute until you don't find it... starting at the top of the document and stopping at the end
Do Until .Execute = False
oRng.Offset(l, 0).Formula = rngSearch.Text
l = l + 1
Loop
End With

' should use proper error handling here
On Error GoTo 0
Set oRng = oBook.Sheets(1).Range("B2")
l = 0

'set up the search
Set rngSearch = ActiveDocument.Content
With rngSearch.Find
.Style = "New Word"
.Wrap = wdFindStop
.Format = True
'now execute until you don't find it... starting at the top of the document and stopping at the end
Do Until .Execute = False
oRng.Offset(l, 0).Formula = rngSearch.Text
l = l + 1
Loop
End With

' should use proper error handling here
On Error GoTo 0
Set oRng = oBook.Sheets(1).Range("C2")
l = 0

'set up the search
Set rngSearch = ActiveDocument.Content
With rngSearch.Find
.Style = "Title Graphics"
.Wrap = wdFindStop
.Format = True
'now execute until you don't find it... starting at the top of the document and stopping at the end
Do Until .Execute = False
oRng.Offset(l, 0).Formula = rngSearch.Text
l = l + 1
Loop
End With

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

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

[Frosty]

This is a good example of when to modularize your code to make it simpler to adjust and troubleshoot. Whenever you're repeating code chunks, that's an indication you can use a subroutine to do the same thing, but using parameters. For instance..

Sub frosty_geek()
'
' frosty_geek Macro
'
'
Dim oExcel As Object
Dim oBook As Object

' 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
'create the workbook
Set oBook = oExcel.Workbooks.Add

'with the first sheet of the work book...
With oBook.Sheets(1)
'do the first style
FindStyleAndPutInExcel "Activity Footage", .Range("A2")

'and the second...
FindStyleAndPutInExcel "New Word", .Range("B2")

'and the third... you get the idea
FindStyleAndPutInExcel "Title Graphics", .Range("C2")
End With

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

Set oBook = Nothing
Set oExcel = Nothing
End Sub
Public Sub FindStyleAndPutInExcel(sStyleName As String, oExcelRng As Object)
Dim rngSearch As Range
Dim l As Long

Set rngSearch = ActiveDocument.Content
With rngSearch.Find
.Style = sStyleName
.Wrap = wdFindStop
.Format = True
'now execute until you don't find it
Do Until .Execute = False
oExcelRng.Offset(l, 0).Formula = rngSearch.Text
l = l + 1
Loop
End With
End Sub

[Frosty]

Oh, and in answer to your question about opening an existing file. I don't know. But you can find out simply by recording a macro and opening up a file. Then post the code here. About the only thing I know that's useful to this is the use of Application.PathSeparator which will use "\" for windows and whatever is appropriate for Mac.

[soldtoscienc]

Woah, definitely looks a lot cleaner when you modularize it, though I don't quite understand how you got there, it's definitely way easier to edit and work with.

Definitely a lesson to remember, when you find yourself repeating things over and over, or copy pasting the same thing again and again. There's a better way to do it :).


Anyhoo, I promise I'll hit the record button before I ask anymore questions haha. Though it looks like word was only able to record the directory, not the actual opening of the excel doc, which was named macro_test.xlsx



Sub open_exceldoc()
'
' open_exceldoc Macro
'
'
ChangeFileOpenDirectory _
"Mac Harddrive:Users:Me:Work:Documents:2012-05 Scripts:"
End Sub


However, when I recorded it in excel I got:

Sub openss()
'
' openss Macro
'

'
Workbooks.Open Filename:= _
"Mac Harddrive:Users:ME:Work:Documents:2012-05 Scripts:macro_test.xlsx"
Windows("Workbook1").Activate
End Sub

[Frosty]

The way I got there was to move the one meaningful variable (oRng As Object) to a parameter of the new subroutine. Well, and I understand more what's going on than you do, because I'm a programmer ;)

You were copying/pasting chunks of code you didn't need to copy (like the On Error GoTo 0 line of code), and you don't need the l=0 reset line anymore, because moving the Dim l as Long into the new subroutine means that it gets "reset" each time the routine is called... so it always starts as 0, each time.