If the document is as you describe, with the data all in one row, the following will extract the data from it to a worksheet (which it will create if it doesn't exist).
If the document is not as you describe, then you will find examples of how to extract data from forms and documents on my web site and a utility add-in for extracting data from forms.
Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 11 Apr 2020
Private Const strPath As String = "C:\DataPath\"
Private Const strWorkbook As String = "C:\DataPath\DataWorkbookName.xlsx"
Private Const strSheet As String = "Sheet1"
Sub ExtractData()
Dim orng As Range
Dim strText As String
Dim vText As Variant
Dim i As Integer
Dim bTrue As Boolean
strText = "": bTrue = False
Set orng = ActiveDocument.Range
With orng.Find
Do While .Execute("1. name ")
orng.Collapse 0
orng.MoveEndUntil "0123456789"
strText = Trim(orng.Text) & "', '"
Exit Do
Loop
End With
Set orng = ActiveDocument.Range
With orng.Find
Do While .Execute("smoke ")
orng.Collapse 0
orng.MoveEndUntil "("
orng.Collapse 0
orng.MoveEndUntil ")"
orng.End = orng.End + 1
If InStr(1, orng.Text, "x") > 0 Then
strText = strText & "True" & "', '"
bTrue = True
Else
strText = strText & "False" & "', '"
End If
Exit Do
Loop
End With
Set orng = ActiveDocument.Range
With orng.Find
Do While .Execute(" no 4. ")
orng.Collapse 0
For i = 1 To 3
orng.MoveEndUntil ")"
orng.End = orng.End + 1
Next i
orng.End = orng.End + 1
vText = Split(orng.Text, ")")
If bTrue = False Then
strText = strText & "0"
Else
For i = 0 To 2
If InStr(vText(i), "x") > 0 Then
Select Case i
Case 0: strText = strText & "1"
Case 1: strText = strText & "2"
Case 2: strText = strText & "7"
Case Else: strText = strText & "0"
End Select
End If
Next i
End If
Exit Do
Loop
WriteToXL strText
End With
lbl_Exit:
Set orng = Nothing
Exit Sub
End Sub
Sub WriteToXL(strValues As String)
'Graham Mayor - https://www.gmayor.com - Last updated - 11 Apr 2020
Dim xlApp As Object
Dim xlWB As Object
Dim bXLStarted As Boolean
CreateFolders strPath
If Not FileExists(strWorkbook) Then
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXLStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Add
With xlWB.Sheets(1)
.Range("A1") = "Name"
.Range("B1") = "Smokes"
.Range("C1") = "Frequency"
.Range("A1:C1").Style = "Accent1"
.Columns(1).ColumnWidth = 16
.Columns(1).NumberFormat = "General"
.Columns(2).ColumnWidth = 16
.Columns(2).NumberFormat = "General"
.Columns(3).ColumnWidth = 16
.Columns(3).NumberFormat = "General"
End With
xlWB.SaveAs strWorkbook
xlWB.Close 1
If bXLStarted Then
xlApp.Quit
Set xlApp = Nothing
Set xlWB = Nothing
End If
End If
WriteToWorksheet strWorkbook:=strWorkbook, strRange:="Sheet1", strValues:=strValues
DoEvents
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
Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lng_PathSep = InStr(3, strPath, "\")
If lng_PathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
If lng_PathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lng_PathSep = 0
If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
oFSO.CreateFolder Left(strPath, lng_PathSep)
End If
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub
Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strFullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function