Import Word Table Macro running very slow

[prkhan56]

Hello All,
I am using Windows XP/Office 2003

I am running this macro from excel (downloaded from newsgroup) which
reads the information from Word Tables in Excel.

Sub ImportDoc()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdTable As Word.Table
Dim wdRow As Word.Row
Dim wdCell As Word.Cell
Dim nRow, nCol, nTab
Dim bHeader As Boolean
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(Filename:="C:\Test.doc")
wdApp.Visible = True
'Call or insert your table copying code here
Range("A1:E999").Clear
nTab = 1
nRow = 1
For Each wdTable In wdDoc.Tables
nTab = nTab + 1
bHeader = True
For Each wdRow In wdTable.Rows
nCol = 1
nRow = nRow + 1
For Each wdCell In wdRow.Cells
nCol = nCol + 1
With ActiveSheet.Cells(nRow, nCol)
.Select
.Font.Bold = bHeader
If bHeader Then
.HorizontalAlignment = xlCenter
Else
.HorizontalAlignment = xlHAlignGeneral
End If
End With
wdCell.Range.Copy
ActiveSheet.Paste
Next
bHeader = False
Next
nRow = nRow + 1
Next


wdApp.ActiveDocument.Close
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing


End Sub

I am facing the folloiwng problems with the above macro.
When the macro runs

1) Word Document (Test.doc) is shown after about 10-15 second on the
screen with the cursor blinking - I wish this not to be displayed

2) Excel file is displayed reading from the Word Table and inserting
info in the cells of Excel...this process is very very slow.. It takes
about two to two and a half minutes to insert a 40 Rows x 11 Columns
information.

3) I have to select all rows and column and do Autofit manually for
rows and columns - Can this be done automatically.



Can anyone help me to speed up this please?

TIA

Rashid Khan

 

[Jim Cone]

Untested...
'---
Sub ImportDoc_R1()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdTable As Word.Table
Dim wdRow As Word.Row
Dim wdCell As Word.Cell
Dim nRow As Long
Dim nCol As Long
Dim bHeader As Boolean

Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(Filename:="C:\Test.doc")
'wdApp.Visible = True
Application.ScreenUpdating = False
ActiveSheet.Range("A1:E999").Clear
nRow = 1
For Each wdTable In wdDoc.Tables
bHeader = True
For Each wdRow In wdTable.Rows
nCol = 1
nRow = nRow + 1
For Each wdCell In wdRow.Cells
nCol = nCol + 1
With ActiveSheet.Cells(nRow, nCol)
.Font.Bold = bHeader
If bHeader Then
.HorizontalAlignment = xlCenter
Else
.HorizontalAlignment = xlHAlignGeneral
End If
wdCell.Range.Copy
.Paste
End With
Next
bHeader = False
Next
nRow = nRow + 1
Next

Set wdTable = Nothing
Set wdRow = Nothing
Set wdCell = Nothing
wdDoc.Close SaveChanges:=wdDoNotSaveChanges
Set wdDoc = Nothing
wdApp.Quit
Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub
--
Jim Cone
Portland, Oregon USA
Special Sort add-in review: http://www.contextures.com/excel-sort-addin.html

..
..
..

"prkhan56" <[email protected]>
wrote in message
Hello All,
I am using Windows XP/Office 2003
I am running this macro from excel (downloaded from newsgroup) which
reads the information from Word Tables in Excel.

-snip-

I am facing the folloiwng problems with the above macro.
When the macro runs
1) Word Document (Test.doc) is shown after about 10-15 second on the
screen with the cursor blinking - I wish this not to be displayed

2) Excel file is displayed reading from the Word Table and inserting
info in the cells of Excel...this process is very very slow.. It takes
about two to two and a half minutes to insert a 40 Rows x 11 Columns
information.

3) I have to select all rows and column and do Autofit manually for
rows and columns - Can this be done automatically.

Can anyone help me to speed up this please?
TIA
Rashid Khan

 

[prkhan56]

Hello Jim,
After running the macro I get the following error.

Run time error 438
Object doesn't support this property.

Thanks for your time

 

[Jim Cone]

Update:

Change...
wdDoc.Close SaveChanges:=wdDoNotSaveChanges

To...
wdDoc.Close SaveChanges:=0
'--
Jim Cone

 

[Jim Cone]

At what line in the code does the error occur?
'--
Jim Cone

 

[prkhan56]

At what line in the code does the error occur?
'--
Jim Cone

I changed the line as per your suggestion.
I stepped into the code (F8) I receive after .Paste on the following
line

wdCell.Range.Copy
.Paste

Thanks once again

 

[Jim Cone]

Yup...

Change .Paste to .PasteSpecial
'--
Jim Cone

At what line in the code does the error occur?
'--
Jim Cone

I changed the line as per your suggestion.
I stepped into the code (F8) I receive after .Paste on the following line

wdCell.Range.Copy
.Paste

Thanks once again

 

[prkhan56]

Yup...

Change .Paste  to  .PasteSpecial
'--
Jim Cone




I changed the line as per your suggestion.
I stepped into the code (F8) I receive after .Paste on the following line

wdCell.Range.Copy
         .Paste

Thanks once again

I changed the code as per your instructions.
The macro runs for 4-5 mins now and puts the Word Tables as Embedded
Object (nearly 500 Objects)
Have I done something wrong.

Thanks once again

 

[Jim Cone]

RE: "Change .Paste to .PasteSpecial"

"I changed the code as per your instructions.
The macro runs for 4-5 mins now and puts the Word Tables as Embedded
Object (nearly 500 Objects)
Have I done something wrong."
'--
Well that is very interesting.
PasteSpecial has an option that should fix the situation...

Change..
..PasteSpecial
To...
..PasteSpecial xlPasteValues
'--
Jim Cone

 

[prkhan56]

RE:  "Change .Paste to .PasteSpecial"

      "I changed the code as per your instructions.
       The macro runs for 4-5 mins now and puts the Word Tables as Embedded
       Object (nearly 500 Objects)
       Have I done something wrong."
'--
Well that is very interesting.  
PasteSpecial has an option that should fix the situation...

Change..
.PasteSpecial
To...
.PasteSpecial xlPasteValues
'--
Jim Cone

Hi Jim,
Thanks for revised code.
It works (just under 2 minutes) but now many date values have changed
eg 01/06/2010 changed to 06/01/2010 (I am using dd/mm/yyyy) format.
Pls note that some date are shown properly...only some have changed.
Can you see about this problem please?

 

[Jim Cone]

This could also be a little faster...
'---
Sub ImportDoc_R2(Optional ByRef bHeader As Boolean = True)
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdTable As Word.Table
Dim wdCell As Word.Cell
Dim wdRow As Word.Row
Dim lngAlign As Long
Dim nRow As Long
Dim nCol As Long

Application.ScreenUpdating = False
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(Filename:="C:\Test.doc")
With ActiveSheet.Range("A1:E999")
.Clear
.NumberFormat = "dd/mm/yyyy"
.Font.Bold = bHeader
If bHeader Then
.HorizontalAlignment = xlCenter
Else
.HorizontalAlignment = xlHAlignGeneral
End If
End With
nRow = 1

For Each wdTable In wdDoc.Tables
For Each wdRow In wdTable.Rows
nCol = 1
nRow = nRow + 1
For Each wdCell In wdRow.Cells
nCol = nCol + 1
With ActiveSheet.Cells(nRow, nCol)
wdCell.Range.Copy
.PasteSpecial xlPasteValues
End With
Next
bHeader = False
Next
nRow = nRow + 1
Next

Set wdTable = Nothing
Set wdRow = Nothing
Set wdCell = Nothing
wdDoc.Close SaveChanges:=0
Set wdDoc = Nothing
wdApp.Quit
Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub

--
Jim Cone
Portland, Oregon USA
http://www.mediafire.com/PrimitiveSoftware

..
..
..

"prkhan56" <[email protected]>
wrote in message
Hi Jim,
Thanks for revised code.
It works (just under 2 minutes) but now many date values have changed
eg 01/06/2010 changed to 06/01/2010 (I am using dd/mm/yyyy) format.
Pls note that some date are shown properly...only some have changed.
Can you see about this problem please?

 

[prkhan56]

This could also be a little faster...
'---
Sub ImportDoc_R2(Optional ByRef bHeader As Boolean = True)
 Dim wdApp As Word.Application
 Dim wdDoc As Word.Document
 Dim wdTable As Word.Table
 Dim wdCell As Word.Cell
 Dim wdRow As Word.Row
 Dim lngAlign As Long
 Dim nRow As Long
 Dim nCol As Long

 Application.ScreenUpdating = False
 Set wdApp = New Word.Application
 Set wdDoc = wdApp.Documents.Open(Filename:="C:\Test.doc")
 With ActiveSheet.Range("A1:E999")
     .Clear
     .NumberFormat = "dd/mm/yyyy"
     .Font.Bold = bHeader
      If bHeader Then
         .HorizontalAlignment = xlCenter
      Else
         .HorizontalAlignment = xlHAlignGeneral
      End If
 End With
 nRow = 1

 For Each wdTable In wdDoc.Tables
   For Each wdRow In wdTable.Rows
     nCol = 1
     nRow = nRow + 1
     For Each wdCell In wdRow.Cells
       nCol = nCol + 1
       With ActiveSheet.Cells(nRow, nCol)
          wdCell.Range.Copy
         .PasteSpecial xlPasteValues
       End With
     Next
     bHeader = False
   Next
   nRow = nRow + 1
 Next

 Set wdTable = Nothing
 Set wdRow = Nothing
 Set wdCell = Nothing
 wdDoc.Close SaveChanges:=0
 Set wdDoc = Nothing
 wdApp.Quit
 Set wdApp = Nothing
 Application.ScreenUpdating = True
End Sub

--
Jim Cone
Portland, Oregon  USAhttp://www.mediafire.com/PrimitiveSoftware

.
.
.

"prkhan56" <[email protected]>
wrote in message
Hi Jim,
Thanks for revised code.
It works (just under 2 minutes) but now many date values have changed
eg 01/06/2010 changed to 06/01/2010 (I am using dd/mm/yyyy) format.
Pls note that some date are shown properly...only some have changed.
Can you see about this problem please?

Hi Jim
I cant run this macro.
I can't even see it under the Macro Name
I think it has to with the line:
Sub ImportDoc_R2(Optional ByRef bHeader As Boolean = True)

Kindly guide me
Thanks

 

[Jim Cone]

Try this one...
'---
Sub ImportDoc_R3()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdTable As Word.Table
Dim wdRow As Word.Row
Dim wdCell As Word.Cell
Dim nRow As Long
Dim nCol As Long
Dim bHeader As Boolean

Application.ScreenUpdating = False
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(Filename:="C:\Test.doc")
With ActiveSheet.Range("A1:E999")
.Clear
.NumberFormat = "dd/mm/yyyy"
End With
nRow = 1

For Each wdTable In wdDoc.Tables
bHeader = True
For Each wdRow In wdTable.Rows
nCol = 1
nRow = nRow + 1
For Each wdCell In wdRow.Cells
nCol = nCol + 1
With ActiveSheet.Cells(nRow, nCol)
.Font.Bold = bHeader
If bHeader Then .HorizontalAlignment = xlCenter
wdCell.Range.Copy
.PasteSpecial xlPasteValues
End With
Next
bHeader = False
Next
nRow = nRow + 1
Next

Set wdTable = Nothing
Set wdRow = Nothing
Set wdCell = Nothing
wdDoc.Close SaveChanges:=0
Set wdDoc = Nothing
wdApp.Quit
Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub
'---




"prkhan56" <[email protected]>
wrote in message
Hi Jim
I cant run this macro.
I can't even see it under the Macro Name
I think it has to with the line:
Sub ImportDoc_R2(Optional ByRef bHeader As Boolean = True)

Kindly guide me
Thanks

 

[prkhan56]

Try this one...
'---
Sub ImportDoc_R3()
 Dim wdApp As Word.Application
 Dim wdDoc As Word.Document
 Dim wdTable As Word.Table
 Dim wdRow As Word.Row
 Dim wdCell As Word.Cell
 Dim nRow As Long
 Dim nCol As Long
 Dim bHeader As Boolean

 Application.ScreenUpdating = False
 Set wdApp = New Word.Application
 Set wdDoc = wdApp.Documents.Open(Filename:="C:\Test.doc")
 With ActiveSheet.Range("A1:E999")
     .Clear
     .NumberFormat = "dd/mm/yyyy"
 End With
 nRow = 1

 For Each wdTable In wdDoc.Tables
   bHeader = True
   For Each wdRow In wdTable.Rows
     nCol = 1
     nRow = nRow + 1
     For Each wdCell In wdRow.Cells
       nCol = nCol + 1
       With ActiveSheet.Cells(nRow, nCol)
         .Font.Bold = bHeader
          If bHeader Then .HorizontalAlignment = xlCenter
          wdCell.Range.Copy
         .PasteSpecial xlPasteValues
       End With
     Next
     bHeader = False
   Next
   nRow = nRow + 1
 Next

 Set wdTable = Nothing
 Set wdRow = Nothing
 Set wdCell = Nothing
 wdDoc.Close SaveChanges:=0
 Set wdDoc = Nothing
 wdApp.Quit
 Set wdApp = Nothing
 Application.ScreenUpdating = True
End Sub
'---

"prkhan56" <[email protected]>
wrote in message
Hi Jim
I cant run this macro.
I can't even see it under the Macro Name
I think it has to with the line:
Sub ImportDoc_R2(Optional ByRef bHeader As Boolean = True)

Kindly guide me
Thanks

Hi Jim
Thanks once again for your help.
The macro runs now but the "Date" column is still having mixed date
format..,the original code which I posted did not had this problem.


Also a slight problem has occurred because of the following code:
With ActiveSheet.Range("A1:E999")
.Clear
.NumberFormat = "dd/mm/yyyy"
End With

The above code also changes value (which includes serial numbers) in
the range A1:E999...
I desire that only column with the Heading "Date" should retain its
original format as in the word document. All other figures should be
unchanged.


Rashid Khan