Hi, Everyone.

I've got the following code:

Sub Datamerge()
Dim rDcm As Range
Dim r As Long ' row
Dim c As Long ' column
Dim pipe
Dim oMainDoc As Object

==========

Set oMainDoc = CreateObject("Word.Document")
fd = Dialogs(wdDialogFileOpen).Show
Word.Application.ScreenUpdating = False
Selection.Homekey Unit:=wdStory
Selection.Tables(1).Select
Selection.Tables(1).Delete
Selection.SelectColumn
Selection.Cut
Selection.Find.Text = "Drug"
'Selection.Find.Font.Bold = True
Selection.Find.Execute
If Selection.Find.Found = False Then
MsgBox ("Database Column Not Found!  Aborting...")
End
Quit
End If
Selection.Homekey
Selection.Paste
DisplayAlerts = wdAlertsNone
r = 1
Set rDcm = ActiveDocument.Tables(1).Range
With rDcm.Find
  .Text = "Database" ' must be found in a table
  ' otherwise things will get out of control
  .Execute
  ' now rDcm isn't the active document any more
  ' but the result of find.execute
  c = rDcm.Cells(1).ColumnIndex
End With
rDcm.InsertAfter "/"
' beware, this will add a slash in every test run
With rDcm.Tables(1)
  .Cell(r, c).Merge mergeto:=.Cell(r, c + 2)
  For r = 2 To .Rows.count
  ActiveDocument.UndoClear
     '.Cell(r, c).Range.Font.Bold = True
     .Cell(r, c).Merge mergeto:=.Cell(r, c + 2)
     '.Cell(r, c).Select
     ActiveDocument.Range.ParagraphFormat.Alignment =
wdAlignParagraphLeft
  Next
End With
Selection.Homekey Unit:=wdStory
Set rDcm = ActiveDocument.Tables(1).Range
With rDcm.Find
For numb = 0 To rDcm.Rows.count
.Text = numb
.Font.Bold = True
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
.Text = " ^l"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
Next
End With
Selection.Homekey Unit:=wdStory
   Selection.Find.ClearFormatting
   Selection.Find.Font.Bold = True
   With Selection.Find
       .Text = "Database"
       .Forward = True
       End With
   Selection.Find.Execute
   Selection.SelectColumn
   Selection.Cut
   Selection.Find.ClearFormatting
   Selection.Find.Font.Bold = True
   With Selection.Find
       .Text = "Indications"
       .Forward = True
       .Wrap = wdFindContinue
       End With
   Selection.Find.Execute
   Selection.MoveRight Unit:=wdCharacter, count:=2
   Selection.Paste
MsgBox ("All Done!!")
Selection.Homekey Unit:=wdStory
End Sub

============

Basically what it does is merge 3 columns together, move another column
around, and delete some superflous numbering of the rows.  My problem
is that on tables > 800 rows, it runs very slowly and takes up 100% of
the CPU resources, according to Task Manager.  This occurs even if I
set the window to invisible.

Can anyone give me some tips for speeding this puppy up?  Thanks!!

Brian