Microsoft Office Forums - View Single Post - Batch re-naming

gmayor · 06-16-2015, 05:15 AM

If this is a document from a mail merge, it might make more sense to re-merge it using http://www.gmayor.com/individual_merge_letters.htm or http://www.gmayor.com/MergeAndSplit.htm however, if not, and based on your original macro you need the following. Note that this creates the renamed documents in the same folder and does not delete the originals. You could save the documents in a different folder by modifying the SaveAs line.

Code:

Sub NameFiles()
    Application.ScreenUpdating = False
    Dim strFolder As String, strFile As String, wdDoc As Document
    Dim oPara As Paragraph
    Dim oRng As Range
    Dim strText As String
    Dim bFound As Boolean
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    strFile = Dir(strFolder & "\*.doc", vbNormal)
    While strFile <> ""
        Set wdDoc = Documents.Open(Filename:=strFolder & "\" & strFile, _
                                   AddToRecentFiles:=False, _
                                   Visible:=False)
        With wdDoc
            For Each oPara In .Paragraphs
                If Trim(oPara.Range.Words(1)) = "Policy" Then
                    Set oRng = oPara.Range
                    oRng.End = oRng.End - 1
                    strText = Trim(Replace(oRng.Text, "Policy", ""))
                    .SaveAs Filename:=strText & ".doc"
                    bFound = True
                    .Close
                    Exit For
                End If
            Next oPara
            If Not bFound Then .Close 0
        End With
        Set wdDoc = Nothing
        strFile = Dir()
    Wend
    Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function