Quote:
Originally Posted by gmayor
This would be essentially the same as your other queries except in reverse.
Start with your document open and save an empty workbook. Then the following macro will find any text that is bold TNR and starts with 'Speaker' and writes them to the empty worksheet column A
Code:
Option Explicit
Private Const xlWB As String = "C:\Path\Empty Excel File name.xlsx"
Private Const xlSheet As String = "Sheet1"
Sub ExtractText()
Dim oDoc As Document
Dim oRng As Range
Set oDoc = ActiveDocument
Set oRng = oDoc.Range
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Name = "Times New Roman"
.Font.Bold = True
Do While .Execute()
If oRng.Text Like "Speaker*" Then
WriteToWorksheet xlWB, xlSheet, oRng.Text
End If
Loop
End With
lbl_Exit:
Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
|
Thank you gmayor. I tried but the macro doesn't copy text to the empty Excel sheet1. I ticked the "Microsoft Excel 16.0 object library". Is there any other things I need to preprare for the macro? Thanks again for your help!