Cut Text from one table cell to another

mrayncrental · #1 02-07-2014, 12:14 AM

Hi - I am trying to cut text that is in brackets ([text]) from one table cell to another table cell - move all words in brackets from column 3 to column 2.

The macro below works fine ---but if the original cell has 2 sets of bracketed words (e.g. [Set A], [Set B]) then when the text is pasted in the new cell, it overwrites whatever is already in the cell (only end up with [Set B] instead of [Set A] and [Set B])

Instead, I would like to add the pasted text on a new line in the cell with a blank line in between.

Any suggestions????

Code:

    Dim keepSearch As Boolean
    Dim Count As Integer
    
        
    ActiveDocument.Tables(1).Select
    
    Do
        Selection.Tables(1).Columns(3).Select
                     
        With Selection.Find
            .ClearFormatting
            .Text = "["
            .Replacement.ClearFormatting
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Execute
        End With
        If Selection.Find.Found Then
            Selection.Extend
            keepSearch = True
            
            ' find second quote of this pair

             With Selection.Find
                .ClearFormatting
                .Text = "]"
                .Replacement.ClearFormatting
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindStop
                .Execute
            End With
            
'Move selected text to column left
            Selection.Cut
            Selection.MoveLeft Unit:=wdCell
            Selection.PasteAndFormat (wdPasteDefault)
            Selection.MoveRight Unit:=wdCell
 
         Else
            keepSearch = False
         End If

    Loop While keepSearch

macropod · #2 02-07-2014, 05:19 PM

Try:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Tables(1).Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[*\]"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    If .InRange(ActiveDocument.Tables(1).Range) Then
      If .Cells(1).ColumnIndex = 3 Then
        .Cut
        Set Rng = .Cells(1).Previous.Range
        With Rng
          .End = .End - 1
          If Len(.Text) > 0 Then .InsertAfter Chr(11)
          .Collapse wdCollapseEnd
          .Paste
        End With
      End If
      .Find.Execute
    Else
      Exit Do
    End If
  Loop
End With
Application.ScreenUpdating = True
End Sub

Note: As coded, the macro inserts manual line breaks between the entries. For paragraph breaks, change Chr(11) to vbCr.

macropod · #3 02-08-2014, 11:11 PM

Cross-posted at: http://windowssecrets.com/forums/sho...ut-overwriting
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184

mrayncrental · #4 02-09-2014, 01:49 PM

This worked perfectly and is more efficient. Added 2 minor tweaks:

- Some of my cells have more than one set of [] words, so I subtracted the row number to research the cell again if first set is found

- Added additional row return

Code:

Sub 1()
'
' Macro to take any [] words from column 3 and move to column 2,
' then search and replace to remove the brackets
'

    Dim rng As Range, rng2 As Range, sText As String
    Dim aTbl As Table, iRow As Integer, aCell As Cell
    
    Set aTbl = ActiveDocument.Tables(1)
    Set rng = aTbl.Range
    
    For iRow = 1 To aTbl.Rows.Count
      Set rng = aTbl.Cell(iRow, 3).Range
      
      With rng.Find
        .ClearFormatting
        .Text = "\[*\]"
        .MatchWildcards = True
        
        If .Execute = True Then
          sText = Replace(rng.Text, "[", "")
          sText = Replace(sText, "]", "")
          Set rng2 = aTbl.Cell(iRow, 2).Range
          
          If Len(rng2.Text) > 2 Then
            rng2.MoveEnd Unit:=wdCharacter, Count:=-1
            rng2.Collapse Direction:=wdCollapseEnd
            rng2.Text = vbCr & vbCr & sText
          Else
            rng2.Text = sText
          End If
          
          rng.Delete

' Don't advance cell unless no brackets found
          
          iRow = iRow - 1
        
        End If
      End With
    Next iRow

End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Can I create a single-cell table that moves with the text?	lcaretto	Word Tables	7	11-01-2013 06:04 AM
Enter text into next available cell in a table	molesy	Word VBA	2	09-11-2013 02:25 AM
Text Form Fields - Filling the table cell	simville02	Word Tables	1	01-31-2013 11:12 PM
Text Wrapping on Fixed Lines in a Form field/Table cell	okrmjr	Word Tables	0	10-30-2009 08:52 AM
Auto-populate an MS Word table cell with text from a diff cell?	dreamrthts	Word Tables	0	03-20-2009 01:49 PM