Code: Select all
Sub SentencesToXL()
Dim xlApp As Object
Dim xlWbk As Object
Dim xlWsh As Object
Dim i As Long
Dim s As Range
Dim m As String
Dim n As Long
Dim j As Long
On Error Resume Next
Set xlApp = GetObject(Class:="Excel.Application")
On Error GoTo 0
If xlApp Is Nothing Then
Set xlApp = CreateObject(Class:="Excel.Application")
End If
xlApp.ScreenUpdating = False
Set xlWbk = xlApp.Workbooks.Add(-4167) ' xlWBatWorksheet
Set xlWsh = xlWbk.Worksheets(1)
For i = 1 To ActiveDocument.Sentences.Count
Set s = ActiveDocument.Sentences(i)
If Not s.ParagraphStyle Is Nothing Then
xlWsh.Range("C" & i).Value = s.ParagraphStyle
End If
xlWsh.Range("D" & i).Value = (Len(s) < Len(s.Paragraphs(1).Range))
Select Case s.ListFormat.ListType
Case wdListNoNumbering
m = "No list"
Case wdListListNumOnly
m = "ListNum fields"
Case wdListBullet
m = "Bulleted list"
Case wdListSimpleNumbering
m = "Simple numbered list"
Case wdListOutlineNumbering
m = "Outlined list"
Case wdListMixedNumbering
m = "Mixed numbered list"
Case wdListPictureBullet
m = "Picture bulleted list"
End Select
xlWsh.Range("E" & i).Value = m
xlWsh.Range("F" & i).Value = s.Information(wdWithInTable)
n = s.InlineShapes.Count
If n > 0 Then
xlWsh.Range("G" & i).Value = n & " inline shape(s)"
End If
n = s.ShapeRange.Count
If n > 0 Then
xlWsh.Range("H" & i).Value = n & " floating shape(s)"
End If
xlWsh.Range("A" & i).Value = i
xlWsh.Range("B" & i).Select
s.Copy
xlWsh.Paste
Next i
xlWsh.DrawingObjects.Delete
xlWsh.UsedRange.EntireColumn.AutoFit
xlWsh.UsedRange.EntireRow.AutoFit
xlApp.Visible = True
xlApp.ScreenUpdating = True
End Sub