Create a folder and perform a SaveAs

I have this code that is working as intended. Since I am still learning VBA and coding, I was wondering if anyone could look at this at let me know if there is another way to write this. This is part of an Add-In I created and is used by several other people (meaning that I installed the Add-In onto their PCs).

Sub Ex()
If InStr(LCase$(ActiveWorkbook.name), "extract") > 0 Then
    Exit Sub
Else
     Dim MyDir As String, fn As String
     MyDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\Extract Files" ' change this to valid path
     If Len(Dir(MyDir, vbDirectory)) = 0 Then MkDir MyDir
     fn = MyDir & "\Extract - " & Format(Now, "mm-dd-yyyy hh_mm")
     ActiveWorkbook.SaveAs Filename:=fn, FileFormat:=xlOpenXMLWorkbook
End If
End Sub

I had a problem with the code creating a new file each time the custom menu button (which is the trigger for the add-in and has other tools that are used on this workbook) was activated, so I added this to prevent that from occurring:

If InStr(LCase$(ActiveWorkbook.name), "extract") > 0 Then
        Exit Sub
    Else

Please let me know if there is any room for improvement of the way this is constructed.

You haven't mentioned exactly what triggers this code, but it might run on any open workbook, even if that workbook is confidential to the active user. You might want to consider checking if the activeworkbook is actually a workbook that you want to save. For example, you could check for a document property or a sheetname.

I've made a few changes

The InStr function can be case-insensitive, so you don't need to use the LCase statement

The FileSystemObject makes it easier to work with files and folders, than using MkDir and Dir.

The FileSystemObject has a BuildPath method that makes building paths easier than using concatenation and worrying about whether you need a backslash

Your function and variables were a little ambiguously named... Better to use names that have explicit meanings.

Your SaveAs file name uses mm-dd-yyyy format, but you'll probably be better off with yyyymmdd as your files will then sort alphabetically and chronologically (and it's an ISO standard)

Your SaveAs file name is missing a file extension. It's good practice to add an extension, even if your Explorer settings don't show them, as extensions help Windows to determine which application to use, and they help users identify the files they need to keep/discard.

Sub ExtractFile()      
  'Add a reference to Microsoft Scripting Runtime
  If InStr(1, ActiveWorkbook.Name, "extract", vbTextCompare) > 0 Then
    Exit Sub
  Else
    Dim oFSO As Scripting.FileSystemObject
    Dim folMyDocs As Scripting.Folder
    Dim sExtractsPath As String
    Dim sFilePath As String

    Set oFSO = New Scripting.FileSystemObject
    Set folMyDocs = oFSO.GetFolder(CreateObject("WScript.Shell").SpecialFolders("MyDocuments"))
    sExtractsPath = oFSO.BuildPath(folMyDocs, "Extract Files")
    If Not oFSO.FolderExists(sExtractsPath) Then
      oFSO.CreateFolder sExtractsPath
    End If
    'sFilePath = oFSO.BuildPath(sExtractsPath, Format(Now, "mm-dd-yyyy hh_mm"))
    sFilePath = oFSO.BuildPath(sExtractsPath, Format(Now, "yyyymmdd-hhmmss") & ".xlsx")
    ActiveWorkbook.SaveAs Filename:=sFileName, FileFormat:=xlOpenXMLWorkbook
  End If

End Sub

StackExchange Code Review Q#116995, answer score: 4