Get Data from Word to Excel
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
On 24 Maj, 07:05, Francis wrote:
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" wrote:
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
On 23 Maj, 12:30, Francis wrote:
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- Ukryj cytowany tekst -
- Pokaż cytowany tekst -
|