Get Data from Word to Excel

[Francis]

Pls ignore my earlier as I press enter too fast.

I have a Word document which contents shows as :

1.Apart from formal legal education, what alternative qualification is
necessary for a legal assistant?

a)a qualification in a related discipline
b)there is no alternative
c)many years of practical experience
d)membership with a recognized association

2.Who supervises a legal assistants work?

a)the Supreme Court
b)the Managing Director
c)a notary public
d)an attorney
e)no one

How do I import these to give me :
Col A = question number
Col B = questions
Col C = answer a)
Col D = answer b)
Col E = answer c)
Col F = answer d)
Col G = answer e)

TIA
--
Hope this is helpful

Pls click the Yes button below if this post provide answer you have asked

Thank You

cheers, francis

Am not a greek but an ordinary user trying to assist another

 

[Jarek Kujawa]

am not sure if this is exactly what you're seeking but it works on my
Office 2007
surely it might be simpler but at the moment I cannot come up with
anything better. let me know if you need variables and descriptions in
English.
--------
pls click YES if this helped
--------


Sub cus()
Dim wrd As Word.Application
Dim myrange As Word.Range
Dim wiersz As String
Dim numer_pytania As String
Dim tekst_pytania As String
Dim numer_PODpytania As String
Dim tekst_PODpytania As String
Dim pytanie As Integer
Dim PODpytanie As Integer

On Error Resume Next

ActiveSheet.UsedRange.Clear

Set wrd = New Word.Application
wrd.DisplayAlerts = wdAlertsNone

With wrd
..Documents.Open Filename:="C:\Eksele\przyklad.docx",
ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False,
PasswordDocument:="", _
PasswordTemplate:="", Revert:=False,
WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto,
XMLTransform:=""
Dim ten_dok As Word.Document
Set ten_dok = .ActiveDocument



For i = 1 To 20 'ten_dok.Paragraphs.Count

PODpytanie = 2

a = .ActiveDocument.Paragraphs(i).Range.Start
a1 = .ActiveDocument.Paragraphs(i).Range.End

Set myrange = ten_dok.Range(Start:=a, End:=a1)


wiersz = myrange.Text

myrange.Select
myrange.Copy

'określ czy dany wiersz zawiera numer pytania
For j = 1 To Len(wiersz)
If Mid(wiersz, j, 1) = "." Then
pytanie = pytanie + 1
numer_pytania = Left(wiersz, j - 1)
tekst_pytania = Right(wiersz, Len(wiersz) - j)
pytanie = pytanie + 1
ActiveSheet.Cells(pytanie, 1) = numer_pytania
ActiveSheet.Cells(pytanie, 2) = tekst_pytania

'idziesz do kolejnego paragrafu
a = .ActiveDocument.Paragraphs(i + 1).Range.Start
a1 = .ActiveDocument.Paragraphs(i + 1).Range.End
Set myrange = ten_dok.Range(Start:=a, End:=a1)
wiersz = myrange.Text

'określ czy dany wiersz zawiera numer PODpytania
For k = 1 To Len(wiersz)
If Mid(wiersz, k, 1) = ")" Then
'wyszukaj kolejny nawias
tekst_PODpytania = Right(wiersz, Len(wiersz) - k)
PODpytanie = PODpytanie + 1
ActiveSheet.Cells(pytanie, PODpytanie) = tekst_PODpytania

For l = 1 To Len(tekst_PODpytania & ")")
If Mid(tekst_PODpytania & ")", l, 1) = ")" Then
znajdz_kolejny_nawias = l
Exit For
End If
Next l

If k + Len(tekst_PODpytania) = Len(wiersz) Then
ActiveSheet.Cells(pytanie, PODpytanie) = Mid
(tekst_PODpytania, 1, znajdz_kolejny_nawias - 2)
Else
Exit For
End If

End If

Next k

Exit For
End If
Next j


Next i
End With

ten_dok.Close
wrd.Quit
Set wrd = Nothing

End Sub

 

[Francis]

Hi Jarek

Thanks. and yes, I do need them in english

--
Hope this is helpful

Pls click the Yes button below if this post provide answer you have asked

Thank You

cheers, francis

Am not a greek but an ordinary user trying to assist another

 

[Jarek Kujawa]

also you need to include a Microsoft Word 12.0 Object Library (or
lower) through Tools->Refereneces->Available references

pls click YES if this helped

Sub cus()
Dim wrd As Word.Application
Dim myrange As Word.Range
Dim row_text As String
Dim question_number As String
Dim question_text As String
Dim subquestion_number As String
Dim subquestion_text As String
Dim question As Integer
Dim subquestion As Integer
Dim find_next_bracket As Integer
Dim this_doc As Word.Document

On Error Resume Next

ActiveSheet.UsedRange.Clear

Set wrd = New Word.Application
wrd.DisplayAlerts = wdAlertsNone

With wrd
..Documents.Open Filename:="C:\Eksele\przyklad.docx",
ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False,
PasswordDocument:="", _
PasswordTemplate:="", Revert:=False,
WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto,
XMLTransform:=""


Set this_doc = .ActiveDocument



For i = 1 To 20 'this_doc.Paragraphs.Count

subquestion = 2

a = .ActiveDocument.Paragraphs(i).Range.Start
a1 = .ActiveDocument.Paragraphs(i).Range.End

Set myrange = this_doc.Range(Start:=a, End:=a1)


row_text = myrange.Text

myrange.Select
myrange.Copy

'determine whether a given row includes numeric question number
For j = 1 To Len(row_text)
If Mid(row_text, j, 1) = "." Then
question = question + 1
question_number = Left(row_text, j - 1)
question_text = Right(row_text, Len(row_text) - j)
question = question + 1
ActiveSheet.Cells(question, 1) = question_number
ActiveSheet.Cells(question, 2) = question_text

'go to the next paragraph
a = .ActiveDocument.Paragraphs(i + 1).Range.Start
a1 = .ActiveDocument.Paragraphs(i + 1).Range.End
Set myrange = this_doc.Range(Start:=a, End:=a1)
row_text = myrange.Text

'determine whether a given row includes subquestion
(a), b), c) etc.)
For k = 1 To Len(row_text)
If Mid(row_text, k, 1) = ")" Then
'search for another bracket ")"
subquestion_text = Right(row_text, Len(row_text) - k)
subquestion = subquestion + 1
ActiveSheet.Cells(question, subquestion) =
subquestion_text

For l = 1 To Len(subquestion_text & ")")
If Mid(subquestion_text & ")", l, 1) = ")" Then
find_next_bracket = l
Exit For
End If
Next l

If k + Len(subquestion_text) = Len(row_text) Then
ActiveSheet.Cells(question, subquestion) = Mid
(subquestion_text, 1, find_next_bracket - 2)
Else
Exit For
End If

End If

Next k

Exit For
End If
Next j


Next i
End With

this_doc.Close
wrd.Quit
Set wrd = Nothing

End Sub

 

[Jarek Kujawa]

seems this macro works only in thisparticular case = when all a) b)
c)... are in the same paragraph

 

[Francis]

Hi Jarek

No problem, I can tweak the codes to suit my requirements

--
Hope this is helpful

Pls click the Yes button below if this post provide answer you have asked

Thank You

cheers, francis

Am not a greek but an ordinary user trying to assist another

 

[Jarek Kujawa]

it would be better to insert Exit For in the loop after the first dot
is found in "If Mid(wiersz, j, 1) = "." Then", cause a dot may also be
in the end of a this same "numeric" paragraph thus causing some
confusion