Import from Word to Excel

Topic

New Reply

Hi

EXcel 2003

I have a Word document with questions and 4 multi-choices answers
Is there a way to import these into Excel with the questions numbers in Col A,
questions in Col B and and the 4 multi-choice answers in Col C,D,E and F respectively

see attached

Reply | Quote

Replies

Here’s a macro that you can run in the Word document. When it finishes, there will be a table on the clipboard ready to be pasted into an Excel workbook.
You can add the header row there and clean up the formatting.

[codebox]
Sub ConvertDoc()
Dim c As String
Selection.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
Do While .Execute(FindText:=”^p^p”, Replace:=wdReplaceNone)
c = ActiveDocument.Range(Start:=Selection.End, End:=Selection.End + 1).Text
If IsNumeric(c) Then
Selection.Text = “@@@@”
Selection.Collapse Direction:=wdCollapseEnd
.Execute FindText:=”.”, ReplaceWith:=”^t”, Replace:=wdReplaceOne
Else
Selection.Text = vbTab
Selection.Collapse Direction:=wdCollapseEnd
Selection.Extend Character:=”)”
Selection.Delete
End If
Selection.Collapse Direction:=wdCollapseEnd
Loop
Selection.HomeKey Unit:=wdStory
Do While .Execute(FindText:=”^p”, ReplaceWith:=”^t”, Replace:=wdReplaceOne) _
And Selection.End < ActiveDocument.Content.End
Selection.Collapse Direction:=wdCollapseEnd
Selection.Extend Character:=")"
Selection.Delete
Loop
Selection.HomeKey Unit:=wdStory
.Execute FindText:="@@@@", ReplaceWith:="^p", Replace:=wdReplaceAll
End With
ActiveDocument.Content.ConvertToTable Separator:=wdSeparateByTabs
ActiveDocument.Tables(1).Range.Copy
End Sub[/codebox]

Reply | Quote

Here’s a macro that you can run in the Word document. When it finishes, there will be a table on the clipboard ready to be pasted into an Excel workbook.
You can add the header row there and clean up the formatting.

[codebox]
Sub ConvertDoc()
Dim c As String
Selection.HomeKey Unit:=wdStory
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
Do While .Execute(FindText:=”^p^p”, Replace:=wdReplaceNone)
c = ActiveDocument.Range(Start:=Selection.End, End:=Selection.End + 1).Text
If IsNumeric© Then
Selection.Text = “@@@@”
Selection.Collapse Direction:=wdCollapseEnd
.Execute FindText:=”.”, ReplaceWith:=”^t”, Replace:=wdReplaceOne
Else
Selection.Text = vbTab
Selection.Collapse Direction:=wdCollapseEnd
Selection.Extend Character:=”)”
Selection.Delete
End If
Selection.Collapse Direction:=wdCollapseEnd
Loop
Selection.HomeKey Unit:=wdStory
Do While .Execute(FindText:=”^p”, ReplaceWith:=”^t”, Replace:=wdReplaceOne) _
And Selection.End < ActiveDocument.Content.End
Selection.Collapse Direction:=wdCollapseEnd
Selection.Extend Character:=")"
Selection.Delete
Loop
Selection.HomeKey Unit:=wdStory
.Execute FindText:="@@@@", ReplaceWith:="^p", Replace:=wdReplaceAll
End With
ActiveDocument.Content.ConvertToTable Separator:=wdSeparateByTabs
ActiveDocument.Tables(1).Range.Copy
End Sub[/codebox]

Hans

Thanks for providing a solution
I got an error error message in the line highlight in red above
It is telling me that variables not define

Just to clarify that I am to run this in Word and not Excel?

TIA

Reply | Quote

Sorry, the Lounge automatically converted ( c ) to ©. I have corrected this; the line should have been

If IsNumeric(c) Then

The code should be run in Word, with the document open.
After running the macro, switch to Excel and press Ctrl+V to paste the table into your workbook.

Reply | Quote

Sorry, the Lounge automatically converted ( c ) to ©. I have corrected this; the line should have been

If IsNumeric(c) Then

The code should be run in Word, with the document open.
After running the macro, switch to Excel and press Ctrl+V to paste the table into your workbook.

Hans

Thanks, this work well. Is it not possible to run this codes from Excel?

TIA

Reply | Quote

Here is a version that you can run from Excel. You’ll be prompted to select a Word document.

[codebox]Sub ConvertDoc()
Dim wrdApp As Object
Dim c As String
Dim wbk As Workbook
‘On Error GoTo ErrHandler
Set wrdApp = CreateObject(“Word.Application”)
If wrdApp.Dialogs(80).Show = True Then
wrdApp.Visible = False
wrdApp.Selection.HomeKey Unit:=6 ‘ wdStory
With wrdApp.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
Do While .Execute(FindText:=”^p^p”, Replace:=0) ‘ wdReplaceNone
c = wrdApp.ActiveDocument.Range(Start:=wrdApp.Selection.End, _
End:=wrdApp.Selection.End + 1).Text
If IsNumeric(c) Then
wrdApp.Selection.Text = “@@@@”
wrdApp.Selection.Collapse Direction:=0 ‘ wdCollapseEnd
.Execute FindText:=”.”, ReplaceWith:=”^t”, Replace:=1 ‘ wdReplaceOne
Else
wrdApp.Selection.Text = vbTab
wrdApp.Selection.Collapse Direction:=0
wrdApp.Selection.Extend Character:=”)”
wrdApp.Selection.Delete
End If
wrdApp.Selection.Collapse Direction:=0
Loop
wrdApp.Selection.HomeKey Unit:=6
Do While .Execute(FindText:=”^p”, ReplaceWith:=”^t”, Replace:=1) _
And wrdApp.Selection.End < wrdApp.ActiveDocument.Content.End
wrdApp.Selection.Collapse Direction:=0
wrdApp.Selection.Extend Character:=")"
wrdApp.Selection.Delete
Loop
wrdApp.Selection.HomeKey Unit:=6
.Execute FindText:="@@@@", ReplaceWith:="^p", Replace:=2 ' wdReplaceAll
End With
wrdApp.ActiveDocument.Content.ConvertToTable Separator:=1 ' wdSeparateByTabs
wrdApp.ActiveDocument.Tables(1).Range.Copy
Set wbk = Workbooks.Add(Template:=xlWBATWorksheet)
wbk.Worksheets(1).Paste
Selection.WrapText = False
End If

ExitHandler:
On Error Resume Next
wrdApp.Quit SaveChanges:=False
Set wrdApp = Nothing
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub[/codebox]

Reply | Quote

Hans

Thanks, its work extremely well.

I appreciate your time and effort on this

Reply | Quote