none
VBA Move Paragraphs in Document Using XL RRS feed

  • Question

  • hi Friends,

    I am trying to move paragraphs inside documents.

    I have made a spreadsheet

    Column A - New Location
    F100
    F200
    F300

    Column B - Paragraph Range
    R100
    R200
    R300

    So the paragraph R100 will be moved to F100, paragraph R200 will be moved to F200 and so forth.


    I have lots of paragraphs to move so I wanted to list them in the spreadsheet then loop to move them to the new location, otherwise  i have to do a lot of copy pasting and may put them in the wrong place -  i may have done this wrong and have been stuck for the whole day :(

    I did a few versions but nothing worked and I am lost now.

    I did this

    Sub MoveParagraphs() Dim xlApp As Object Dim xlWbk As Object Dim xlWsh As Object Dim blnStart As Boolean Dim lngRow As Long Dim lngLastRow As Long Dim oFindParagraph As Range Dim oDoc As Document Dim oRng As Range Dim strFind As String,

    Dim strReplace As String On Error Resume Next Set xlApp = GetObject(Class:="Excel.Application") If xlApp Is Nothing Then Set xlApp = CreateObject(Class:="Excel.Application") If xlApp Is Nothing Then MsgBox "Failed to start Excel", vbExclamation Exit Sub End If blnStart = True End If On Error GoTo ErrHandler Application.ScreenUpdating = False Set xlWbk = xlApp.Workbooks.Open(FileName:="C:\Users\Dan\Desktop\Replace.xlsm") Set xlWsh = xlWbk.Worksheets("Paragraphs") lngLastRow = xlWsh.Range("A" & xlWsh.Rows.Count).End(-4162).Row ' -4162 = xlUp For lngRow = 2 To lngLastRow '--------------------------------------- .Text = xlWsh.Range("A" & lngRow).Value .Replacement = xlWsh.Range("B" & lngRow).Value With oFindParagraph.Find Do While .Execute(FindText:=strReplace) If oFindParagraph.Start = oFind.Paragraphs(1).Range.Start Then oFindParagraph.MoveEndUntil "END" With oRng.Find Do While .Execute(FindText:=strfind) If oRng.Start = oRng.Paragraphs(1).Range.Start Then oRng.MoveEndUntil "END" oRng.End = oRng.Paragraphs.Last.Range.End oRng.FormattedText = oFindParagraph.FormattedText 'Delete old paragraphs End If oRng.Collapse 0 Loop End With End If End With Next lngRow ExitHandler: On Error Resume Next xlWbk.Close SaveChanges:=False If blnStart Then xlApp.Quit End If Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description, vbExclamation Resume ExitHandler End Sub


    I would be grateful to know if there is a better way or how to make this workable


    Cheers Dan



    • Edited by Dan_CS Saturday, July 30, 2016 1:04 AM
    Saturday, July 30, 2016 12:58 AM

Answers

  • Try this version:

    Sub MoveParagraphs()
        Dim xlApp               As Object
        Dim xlWbk               As Object
        Dim xlWsh               As Object
        Dim blnStart            As Boolean
        Dim lngRow              As Long
        Dim lngLastRow          As Long
        Dim strNew              As String
        Dim strOld              As String
        Dim rngNew              As Range
        Dim rngOld              As Range
        
        On Error Resume Next
        Set xlApp = GetObject(Class:="Excel.Application")
        If xlApp Is Nothing Then
            Set xlApp = CreateObject(Class:="Excel.Application")
            If xlApp Is Nothing Then
                MsgBox "Failed to start Excel", vbExclamation
                Exit Sub
            End If
            blnStart = True
        End If
        On Error GoTo ErrHandler
        Application.ScreenUpdating = False
    
        Set xlWbk = xlApp.Workbooks.Open(FileName:="C:\Users\Dan\Desktop\Replace.xlsm")
        Set xlWsh = xlWbk.Worksheets("Paragraphs")
        lngLastRow = xlWsh.Range("A" & xlWsh.Rows.Count).End(-4162).Row ' -4162 = xlUp
        For lngRow = 2 To lngLastRow
            strNew = xlWsh.Range("A" & lngRow).Value
            strOld = xlWsh.Range("B" & lngRow).Value
            Set rngOld = ActiveDocument.Content
            With rngOld.Find
                .ClearFormatting
                .Text = strOld
                .MatchWholeWord = True
                .MatchWildcards = False
                If .Execute Then
                    Set rngOld = rngOld.Paragraphs(1).Range
                    Set rngNew = ActiveDocument.Content
                    With rngNew.Find
                        .ClearFormatting
                        .Text = strNew
                        .MatchWholeWord = True
                        .MatchWildcards = False
                        If .Execute Then
                            Set rngNew = rngNew.Paragraphs(1).Range
                            rngOld.Cut
                            rngNew.Paste
                        End If
                    End With
                End If
            End With
        Next lngRow
            
    ExitHandler:
        On Error Resume Next
        xlWbk.Close SaveChanges:=False
        If blnStart Then
            xlApp.Quit
        End If
        Application.ScreenUpdating = True
        Exit Sub
        
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)


    Saturday, July 30, 2016 9:43 AM

All replies

  • Try this version:

    Sub MoveParagraphs()
        Dim xlApp               As Object
        Dim xlWbk               As Object
        Dim xlWsh               As Object
        Dim blnStart            As Boolean
        Dim lngRow              As Long
        Dim lngLastRow          As Long
        Dim strNew              As String
        Dim strOld              As String
        Dim rngNew              As Range
        Dim rngOld              As Range
        
        On Error Resume Next
        Set xlApp = GetObject(Class:="Excel.Application")
        If xlApp Is Nothing Then
            Set xlApp = CreateObject(Class:="Excel.Application")
            If xlApp Is Nothing Then
                MsgBox "Failed to start Excel", vbExclamation
                Exit Sub
            End If
            blnStart = True
        End If
        On Error GoTo ErrHandler
        Application.ScreenUpdating = False
    
        Set xlWbk = xlApp.Workbooks.Open(FileName:="C:\Users\Dan\Desktop\Replace.xlsm")
        Set xlWsh = xlWbk.Worksheets("Paragraphs")
        lngLastRow = xlWsh.Range("A" & xlWsh.Rows.Count).End(-4162).Row ' -4162 = xlUp
        For lngRow = 2 To lngLastRow
            strNew = xlWsh.Range("A" & lngRow).Value
            strOld = xlWsh.Range("B" & lngRow).Value
            Set rngOld = ActiveDocument.Content
            With rngOld.Find
                .ClearFormatting
                .Text = strOld
                .MatchWholeWord = True
                .MatchWildcards = False
                If .Execute Then
                    Set rngOld = rngOld.Paragraphs(1).Range
                    Set rngNew = ActiveDocument.Content
                    With rngNew.Find
                        .ClearFormatting
                        .Text = strNew
                        .MatchWholeWord = True
                        .MatchWildcards = False
                        If .Execute Then
                            Set rngNew = rngNew.Paragraphs(1).Range
                            rngOld.Cut
                            rngNew.Paste
                        End If
                    End With
                End If
            End With
        Next lngRow
            
    ExitHandler:
        On Error Resume Next
        xlWbk.Close SaveChanges:=False
        If blnStart Then
            xlApp.Quit
        End If
        Application.ScreenUpdating = True
        Exit Sub
        
    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)


    Saturday, July 30, 2016 9:43 AM
  • Thank you very much Hans,

    This worked a treat !

    I recorded many macros to get an insight but it kept well not being very helpful.

    Then the ranges got stuck and the do while would not work etc - #codingissues  - but it seems so logical your method.

    Have a great weekend and thank you for always helping us inexperienced newbies

    :) :)

    Cheers Dan

    Saturday, July 30, 2016 12:12 PM