Macro Execution is Too Slow -- Help!

[VBA_Newbie79]

I have written a macro (with lots of help from this board) that copies the
contents of two Excel worksheets into Word. Once the copy is finished, I
need Word to go through a table and delete all rows where the font is
formatted white. Below is the code. I've tried everything I can think to
turn off screen updating and Word visibility, but it does nothing to speed up
the code. Any help you pros can provide would be very much appreciated.
Thanks!

Sub PrintFlowchart()

Dim oRow As Row
Dim oRows As Range

Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add

wdApp.Visible = False
Word.Application.ScreenUpdating = False
Excel.Application.ScreenUpdating = False
Sheets("Flowchart").Range("A1:V57").Copy
wdApp.Selection.PasteSpecial link:=False,
DataType:=wdPasteMetafilePicture, _
Placement:=wdInLine, DisplayAsIcon:=False
wdApp.Selection.InsertBreak Type:=wdPageBreak

Sheets("Key").Activate
Range("B2").Select
ActiveCell.CurrentRegion.Copy
wdApp.Selection.PasteSpecial link:=False, DataType:=wdPasteRTF

wdApp.Selection.Goto What:=wdGoToTable, Which:=wdGoToFirst, Count:=1,
Name:=""
wdApp.Selection.Tables(1).Select

If wdApp.Selection.Information(wdWithInTable) = False Then Exit Sub

For Each oRow In wdApp.Selection.Tables(1).Rows
If oRow.Cells(1).Range.Font.Color = wdColorWhite Then
oRow.Delete
End If
Next oRow

wdApp.Visible = True
Excel.Application.ScreenUpdating = True
Word.Application.ScreenUpdating = True
Word.Application.Selection.HomeKey Unit:=wdStory

End Sub

 

[old man]

Hi,

I tried rewriting your code to refer to nothing but ranges and to loop
through the rows from the bottom up (so when rows are deleted the table
would not move) but the code actually ran slower (its almost always faster to
refer to a collection with a for each as you do instead of looping through
each row as a row in a table).

Here is a bit of code I wrote that did not help...

rowcount = ActiveDocument.Tables(1).Rows.Count


starttime = Now

With ActiveDocument.Tables(1)
For currow = rowcount To 1 Step -1

If .Rows(currow).Cells(1).Range.Font.Color = wdColorWhite Then
.Rows(currow).Delete
End If
Next currow

End With
endtime = Now

MsgBox "done " & Format(endtime - starttime, "N-S")

When a Word table size grows beyound a certain amount of rows (when it was
under 20 it ran almost instantaneously) performance gets really slow. I
think the only thing you can do is delete the rows in Excel before you paste
the table into Word.

Old Man

 

[Russ]

Hello V,
Rather than iterating through all the rows, I tried to use the find
function. The first subroutine deletes table rows as it finds them. The
second subroutine converts the table to text and deletes paragraphs as it
finds them, then changes the text back to a table. The second one is faster
when there is a lot of white font to find.

'-------------------------------------
'Excel might deal with deleting table rows more quickly.


Sub DeleteAnyWhiteFontRows2()
Call Start_Timer
Dim aTableRange As Word.Range
Dim aTableRange2 As Word.Range
Dim aDoc As Word.Document

Set aDoc = ActiveDocument
Application.ScreenUpdating = False
Set aTableRange = aDoc.Tables(1).Range
Set aTableRange2 = aTableRange.Duplicate
With aTableRange.Find
.Font.ColorIndex = wdWhite
.Wrap = wdFindContinue
.Format = True
Do While .Execute = True
If aTableRange.End >= aTableRange2.End Then
Exit Do
End If
aTableRange.Rows(1).Delete
Loop
End With
Application.ScreenUpdating = True
Call Stop_Timer
End Sub
'-------------------------------------
'Faster yet by using what Word knows best. That is, plain text search and
'destroy. ;-)


Public Sub DeleteAnyWhiteFontRows()
Call Start_Timer
Dim aTableRange As Word.Range
Dim aTableRange2 As Word.Range
Dim aTable As Word.Table
Dim aDoc As Word.Document

Set aDoc = ActiveDocument
Set aTable = aDoc.Tables(1)
Set aTableRange = aTable.Range
Set aTableRange2 = aTableRange.Duplicate
Application.ScreenUpdating = False
aTable.ConvertToText
With aTableRange.Find
.Font.ColorIndex = wdWhite
.Wrap = wdFindStop
.Format = True
Do While .Execute = True
aTableRange.Paragraphs(1).Range.Delete
If aTableRange.End = aTableRange2.End Then
Exit Do
End If
Loop
End With
aTableRange2.ConvertToTable
Application.ScreenUpdating = True
Call Stop_Timer
End Sub
'-------------------------------------
Public Sub Start_Timer()
Dim StartTime As Long
StartTime = Timer
End Sub

Public Sub Stop_Timer()
MsgBox "Time taken was: " & Format((Timer - StartTime), "###.##") _
& " seconds"
End Sub

 

[Shauna Kelly]

Hi

To add to old man's comments...

Is this code running in Word? I'm assuming the code is running from Excel.
You might try putting the code into Word. If you do that, you won't need to
use New Word.Application. Instead, create a New Excel.Application, open the
Excel file, and make sure you explicitly qualify all the references to the
Excel object model.

The other thing you might do is to use a counter to cycle through the rows
in the table from the bottom up, rather than the top down. So instead of
this:

For Each oRow In wdApp.Selection.Tables(1).Rows
If oRow.Cells(1).Range.Font.Color = wdColorWhite Then
oRow.Delete
End If
Next oRow

Try something like this:

Dim lngRowCount as long
Dim lngCounter as Long
Dim oTable as Word.Table

'Create a variable to refer to the table, so Word only has
'to find the table once
set oTable = wdApp.Selection.Tables(1)

'Count the number of rows
lngRowCount = oTable.Rows.Count

'From the bottom up, delete a row if
'the text is white
For lngCounter = lngRowCount to 1 Step -1
set oRow = oTable.Rows(lngCounter)
If oRow.Cells(1).Range.Font.Color = wdColorWhite Then
oRow.Delete
End If
Next lngCounter

Hope this helps.

Shauna Kelly. Microsoft MVP.
http://www.shaunakelly.com/word

 

[Russ]

V,

Better to remove:

Dim StartTime As Long

From the
Start_Timer() sub.

And put:

Public StartTime As Long

In the (DECLARATIONS) section of the project.