Renaming docs in a folder, as per specific field.

Hi guys,

Managed to split my document, as per my requirements.

Now the issue is, they are all named 'Notes 001, Notes 002 and so on'

I have found a macro that will rename the documents as per the first line.

The issue is, they all begin with the same first line.

Code:

---

Sub GetRenameFiles()
    Dim fd As FileDialog
    Dim strFolder As String
    Dim strFile As String
    Dim aDoc As Document
    Dim rngNewName As Range
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "Select the folder that contains the files."
        If .Show = -1 Then
            strFolder = .SelectedItems(1) & "\"
        Else
            MsgBox "You did not select a folder."
            Exit Sub
        End If
    End With
    strFile = Dir$(strFolder & "*.doc*")
    While strFile <> ""
        Set aDoc = Documents.Open(strFolder & strFile)
        Set rngNewName = aDoc.Paragraphs(1).Range
        rngNewName.MoveEnd wdCharacter, -1
        aDoc.SaveAs2 rngNewName.Text
        aDoc.Close
        strFile = Dir$()
    Wend
End Sub

---

I need it to basically find the section that says 'title:' and then rename the document as the text next to title. I have also discovered that 'title:', isn't always in the same place in the document.

Thanks

Assuming it is delineated something like this:

Title: War and Peace(Paragraph mark)

Code:

---

Sub GetRenameFiles()
Dim oFD As FileDialog
Dim strFolder As String
Dim strFile As String
Dim oDoc As Document
Dim oRng As Range
  Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
  With oFD
    .Title = "Select the folder that contains the files."
    If .Show = -1 Then
      strFolder = .SelectedItems(1) & "\"
    Else
      MsgBox "You did not select a folder."
      Exit Sub
    End If
  End With
  strFile = Dir$(strFolder & "*.doc*")
  While strFile <> ""
    Set oDoc = Documents.Open(strFolder & strFile)
    Set oRng = oDoc.Range
    With oRng.Find
      .Text = "Title"
      If .Execute Then
        oRng.MoveEndUntil Chr(13)
        oRng.Start = oRng.Start + 7
      End If
    End With
      oDoc.SaveAs2 oRng.Text
      oDoc.Close
    strFile = Dir$()
  Wend
End Sub

---

That's absolutely spot on greg. The only issue I am having, is if it happens to find something with a duplicate name, its just writing over the top, rather than saving as something else.

Also, is there an easy way to put say some text on the end of the title its saved as? So like

If the document is called: ubsfuib 2004, so like adding 2004 to the end? have tried myself, but im basically rubbish.

- Cancel the last request Managed to get it to work by adding & " 2004" to filename section...

I'm actually learning. Greg you're wonderful.

Code:

---

Sub GetRenameFiles()
Dim oFD As FileDialog
Dim strFolder As String
Dim strFile As String
Dim oDoc As Document
Dim oRng As Range
Dim oFSO As Object
  Set oFSO = CreateObject("Scripting.FileSystemObject")
 
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    With oFD
        .Title = "Select the folder that contains the files."
        If .Show = -1 Then
            strFolder = .SelectedItems(1) & "\"
        Else
            MsgBox "You did not select a folder."
            Exit Sub
        End If
    End With
    strFile = Dir$(strFolder & "*.doc*")
    While strFile <> ""
        Set oDoc = Documents.Open(strFolder & strFile)
        Set oRng = oDoc.Range
        With oRng.Find
            .Text = "Title"
            If .Execute Then
                oRng.MoveEndUntil Chr(13)
                oRng.Start = oRng.Start + 7
            End If
        End With
        If Not oFSO.FileExists(oDoc.Path & "\" & oRng.Text & Right(oDoc.Name, Len(oDoc.Name) - InStr(oDoc.Name, ".") + 1)) Then
          oDoc.SaveAs2 oRng.Text
        Else
          oDoc.SaveAs2 oRng.Text & "-dup"
        End If
       
        oDoc.Close
        strFile = Dir$()
    Wend
End Sub

---

Quote:

---

Originally Posted by gmaxey

Code:

---

Sub GetRenameFiles()
 Dim oFD As FileDialog
 Dim strFolder As String
 Dim strFile As String
 Dim oDoc As Document
 Dim oRng As Range
 Dim oFSO As Object
  Set oFSO = CreateObject("Scripting.FileSystemObject")
 
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    With oFD
        .Title = "Select the folder that contains the files."
        If .Show = -1 Then
            strFolder = .SelectedItems(1) & "\"
        Else
            MsgBox "You did not select a folder."
            Exit Sub
        End If
    End With
    strFile = Dir$(strFolder & "*.doc*")
    While strFile <> ""
        Set oDoc = Documents.Open(strFolder & strFile)
        Set oRng = oDoc.Range
        With oRng.Find
            .Text = "Title"
            If .Execute Then
                oRng.MoveEndUntil Chr(13)
                oRng.Start = oRng.Start + 7
            End If
        End With
        If Not oFSO.FileExists(oDoc.Path & "\" & oRng.Text & Right(oDoc.Name, Len(oDoc.Name) - InStr(oDoc.Name, ".") + 1)) Then
          oDoc.SaveAs2 oRng.Text
        Else
          oDoc.SaveAs2 oRng.Text & "-dup"
        End If
       
        oDoc.Close
        strFile = Dir$()
    Wend
 End Sub

---

---

Ive got a feeling, that me adding & " 2004" is stopping the -dup part from working! :(

Change that, I did it without the addition, and it still is writing over the top of the documents its just creating. So I started with 100 documents, which contained 10 duplicate titles, And I'm still ending up with 90 documents, with non ending in -dup.

And will multiple duplicates end up with like Filename-dup-dup?

Were is your code?

Code:

---

If oFSO.FileExists(oRng.Text) = True Then
    oDoc.SaveAs2 oRng.Text & "-dup"
    Else
    oDoc.SaveAs2 oRng.Text
        End If

---

Its this bit im super struggling with, for the life of me, I cant get it to recognise the duplicate files, regardless of what I try!

Code:

---

If oFSO.FileExists(oDoc.Path & "\" & oRng.Text) = True Then
    oDoc.SaveAs2 oRng.Text & "-dup"
    Else
    oDoc.SaveAs2 oRng.Text
        End If

---

Forgot I need the path for the Filesystemobject. Still no luck!

Are you saying that a situation exists where you my have 3 or more files where the deduced title would be same e.g., Title: A, Title: A, Title: A? In which case after running the code you are left with:

A.docx
A-dup.docx

If so then you need to modify the code with a Do ... Loop statement to index A-dup until the condition exists where A-dupIndex does not exists then save it

I've got to go to school and can't code it for you right now.

Hi, I recently ended up accidentally formatting all my disks including backups. I engaged a specialist and retrieved most of the data.

I now have many thousands of powerpoint, excel and word files named like Found_297934336_13592064.

I need some help in trying out the code you posted here to try and rename my powerpoint files with the presentation Title and similarly with my docx and xlsx files.

I am a complete newbee in Visual Studio though I have done development in Linux environments using C or Python. Your code is right now my only hope and I am going crazy trying to run it in Visual Studio. I realised that I had not chosen the version with Visual Basic. I am now downloading hopefully the right version and will try again. Is there a simpler way than download 4.95 GB of Visual Studio Express for Office extension development to run your code. With my current download speed, it might take for ever.

Meanwhile, to be sure, I would like to know what minimum development environment, plugins or any other prerequisites are required for running your code. Thanks in advance. I am stuck and badly need help.

VBA is Visual Basic for Applications. So if you put that code in Word )or any other Office application) it should run as is.