Solved: Extract all words that have italics

[Tourshi]

Hi, this is probably a really simple piece of code..i've just bought some VBA books too but i'm still an absolute beginner, and for now i just need a quick fix, i'd really appreciate if anyone can help me adjust this code to find words in italics

the part i'm having trouble adjusting is
.Text = "shall" ' the word I am looking for i've tried putting .font.italic = true
but anyway this clearly a newbie speaking, please help :)

thank you -- p.s. the code was submitted by lucas, its in vbaexpresses's knoweldgebase...


Option Explicit

Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
intRowCount = 1
Set aRange = ActiveDocument.Range
With aRange.Find
Do
.Text = "shall" ' the word I am looking for
.Execute
If .Found Then
aRange.Expand Unit:=wdSentence
aRange.Copy
aRange.Collapse wdCollapseEnd
If objSheet Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xls
Set objSheet = appExcel.workbooks.Open("C:\temp\test.xls").Sheets("Sheet1")
intRowCount = 1
End If
objSheet.Cells(intRowCount, 1).Select
objSheet.Paste
intRowCount = intRowCount + 1
End If
Loop While .Found
End With
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub


edit Lucas: VBA tags added to code......when posting please select your code and hit the vba button.

[fumei]

1. Please use the VBA code tags when posting code.

2. Use .Font.Italic = True in the Find loop

With aRange.Find
.Font.Italic = True

[lucas]

to cut down the confusion.....as Gerry points out:
Option Explicit
Sub FindWordCopySentence()
Dim appExcel As Object
Dim objSheet As Object
Dim aRange As Range
Dim intRowCount As Integer
intRowCount = 1
Set aRange = ActiveDocument.Range
With aRange.Find
.Font.Italic = True
Do
' .Text = "shall" ' the word I am looking for
.Execute
If .Found Then
aRange.Expand Unit:=wdSentence
aRange.Copy
aRange.Collapse wdCollapseEnd
If objSheet Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
'Change the file path to match the location of your test.xls
Set objSheet = appExcel.workbooks.Open("f:\temp\test.xls").Sheets("Sheet1")
intRowCount = 1
End If
objSheet.Cells(intRowCount, 1).Select
objSheet.Paste
intRowCount = intRowCount + 1
End If
Loop While .Found
End With
If Not objSheet Is Nothing Then
appExcel.workbooks(1).Close True
appExcel.Quit
Set objSheet = Nothing
Set appExcel = Nothing
End If
Set aRange = Nothing
End Sub

[Tourshi]

Thank you for the help folks... really appreciate it. :)

[mdmackillop]

Hi Toursi,
If this is solved you can mark it so using the Thread Tools dropdown
Regards
MD