Microsoft Office Forums - View Single Post - Help to spead up macro - Find and Replace in Tables, Cut Paste Next Cells

gmayor · 08-19-2019, 12:50 AM

If, as appears to be the case, the tables have an empty last column and the search relates to the next to last column, then it might be simpler and faster to process the columns e.g. using the macro below. It won't, however cater for merged cells or nested tables.

It would also be much quicker to run the process in Word 2010, but that's another story entirely.

Code:

Sub Macro1()
Dim i As Integer
Dim oTable As Table
Dim oRng As Range, oCell As Range
Dim sText As String
Dim lngCol As Long
    sText = InputBox("Enter text to move cell")
    Application.ScreenUpdating = False
    For Each oTable In ActiveDocument.Tables
        lngCol = oTable.Columns.Count
        For i = 1 To oTable.Rows.Count
            Set oRng = oTable.Cell(i, lngCol - 1).Range
            oRng.End = oRng.End - 1
            If InStr(1, oRng.Text, sText) > 0 Then
                Set oCell = oTable.Cell(i, lngCol).Range
                oCell.End = oCell.End - 1
                oCell.FormattedText = oRng.FormattedText
                oRng.Text = ""
            End If
            DoEvents
        Next i
        DoEvents
    Next oTable
    Application.ScreenUpdating = True
    MsgBox "Tables processed"
lbl_Exit:
    Set oTable = Nothing
    Set oRng = Nothing
    Set oCell = Nothing
    Exit Sub
End Sub