Results 1 to 4 of 4
  1. #1
    New Lounger
    Join Date
    Feb 2014
    Posts
    16
    Thanks
    1
    Thanked 0 Times in 0 Posts

    Question Word Macro - Copy Text from one cell in a table to another cell without overwriting

    I need a macro that will cut all of the text between [] in a table cell and paste in the cell to the left (column 3 to column 2), appending it to the next line of text that already exists in the cell.

    The code below works - but overwrites/deletes what is already in the cell.

    Before I paste the selected [] text, how can I check the table cell to:
    A. is there already text in the cell
    B. go to the end of the current text and add line return
    C. paste the [] text at the beginning of the new line in the cell

    Many thanks!!!

    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

  2. #2
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,524
    Thanks
    3
    Thanked 144 Times in 137 Posts
    Try this version
    Code:
    Sub Temp1()
      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 & sText
            Else
              rng2.Text = sText
            End If
            rng.Delete
          End If
        End With
      Next iRow
    End Sub
    Andrew Lockton, Chrysalis Design, Melbourne Australia

  3. #3
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    3,920
    Thanks
    0
    Thanked 194 Times in 177 Posts
    Cross-posted (and given essentially the same answer some hours earlier) at: http://www.msofficeforums.com/word-v...l-another.html
    For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184. I'm sure Andrew would prefer to not spend time answering a question that's already been answered elsewhere.
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  4. The Following User Says Thank You to macropod For This Useful Post:

    manray (2014-02-09)

  5. #4
    New Lounger
    Join Date
    Feb 2014
    Posts
    16
    Thanks
    1
    Thanked 0 Times in 0 Posts

    Cool Solved

    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •