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. Get our unique weekly Newsletter with tips and techniques, how to's and critical updates on Windows 7, Windows 8, Windows XP, Firefox, Internet Explorer, Google, etc. Join our 480,000 subscribers!

    Excel 2013: The Missing Manual

    + Get this BONUS — free!

    Get the most of Excel! Learn about new features, basics of creating a new spreadsheet and using the infamous Ribbon in the first chapter of Excel 2013: The Missing Manual - Subscribe and download Chapter 1 for free!

  3. #2
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,524
    Thanks
    3
    Thanked 143 Times in 136 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

  4. #3
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    3,917
    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]

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

    manray (2014-02-09)

  6. #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
  •