Can I find a string within a file name and delete that string in VBA?

Question

I am working within a quality system, and I work off of a redlined document (microsoft word). When I go to upload it into our system, I need to upload the redlined version (it says "redlines" in the filename), and then a clean copy and a pdf copy. I have recorded a macro that does everything except changing the file name. Is it possible to search for the word "redlines" in the file name, delete that word, then save it as a new file? This is what I have so far. For example, if my redlined version is called "My File Redlines.docx" I would want it to save the file as "My File.docx". The filename can vary in length, and the location of the word "redlines" can also vary, so it can't be based upon a fixed location.

Sub Macro1()
'
' Macro1 Macro
'
'
    ActiveDocument.Save
    ActiveDocument.SaveAs2 FileName:= _
        **Need help how to do this part. I want to remove the word "Redlines" from the file name**, _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
    ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions
    ActiveDocument.AcceptAllRevisions
    ActiveDocument.Save
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        **This will have the same file name as above, but saved as a PDF** _
        , ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
End Sub

Answer 1

• Using multiple replacement to get the desired file name
• Set Compare:=vbTextCompare to make the replacement case-insensitive.

Microsoft documentation:

Replace function

Sub Macro1()
    Dim sFile As String, sPath As String, aTxt
    sFile = ActiveDocument.Name ' get doc name
    sPath = ActiveDocument.Path & Application.PathSeparator ' get path
    sFile = Replace(sFile, "redlines", "", Compare:=vbTextCompare) ' remove redlines
    sFile = Replace(sFile, "  ", " ", Compare:=vbTextCompare) ' remove dumplicate space
    sFile = Replace(sFile, " .doc", ".doc", Compare:=vbTextCompare) ' remove extra space before .
    Debug.Print sPath & sFile
    ActiveDocument.SaveAs2 FileName:=sPath & sFile, _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
    ActiveDocument.TrackRevisions = Not ActiveDocument.TrackRevisions
    ActiveDocument.AcceptAllRevisions
    ActiveDocument.Save
    aTxt = Split(sFile, ".")
    aTxt(UBound(aTxt)) = "pdf" ' replace extention name with pdf, compatible for *.doc*
    sFile = Join(aTxt, ".")
    Debug.Print sPath & sFile
    ActiveDocument.ExportAsFixedFormat OutputFileName:=sPath & sFile, _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
End Sub