Get Data from Word to Excel

  • Thread starter Thread starter Francis
  • Start date Start date
F

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
 
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
 
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
 
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
 
seems this macro works only in thisparticular case = when all a) b)
c)... are in the same paragraph
 
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
 
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
 
Back
Top