有几件事要提一下：

(1)一件小事：您可以使用ThisWorkbook.Path(请注意，这不包含尾随的反斜杠) 访问工作簿的文件夹。因此使用 strCurrentPath = ThisWorkbook.Path

(2)您将子文件夹名称赋值给名为 的变量，NewPath但后来您访问了strNewPath。CurrentPathAndNamevs也存在同样的问题strCurrentPathAndName。 始终使用 可以避免此类错误Option Explicit。

此外，除非您计划在代码中使用不同的子文件夹作为备份文件夹，否则将新路径声明为常量，而不是变量：

Const strNewPath = "OldForecasts"

（3）正如评论中所提到的，VBA 中有一些用于文件处理的命令（相当旧）：

kill删除文件
Dir以检查文件或文件夹是否存在。要检查文件夹，您需要将其vbDirectory作为第二个参数添加到Dir-command。
MkDir创建文件夹。

代码可能如下所示：

Option Explicit

Sub Createbackupfile()

    Const BackupFolder = "OldForecasts"

    Dim CurrentName As String
    Dim CurrentPathAndName As String
    Dim CurrentPath As String

    With ThisWorkbook
        CurrentName = .Name
        CurrentPathAndName = .FullName
        CurrentPath = .Name

        Dim newPath As String
        newPath = CurrentPath & "\" & BackupFolder
        If Dir(newPath, vbDirectory) = "" Then MkDir newPath
        .SaveAs Filename:=newPath & "\" & CurrentName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        Kill CurrentPathAndName
    End With
End Sub

请注意，如果此代码也需要在 Mac 上运行，则需要将反斜杠替换为斜杠 - 或者使用Application.PathSeparator：

newPath = CurrentPath & Application.PathSeparator & BackupFolder

（据我所知，这些命令本身可以在 Mac 上运行，但我无法检查这一点，因为我没有 Mac 可以测试。）

(4) Scripting FileSystemObjectRuntime 是访问文件和文件夹信息的另一种方式。它比旧命令有一些优势（例如，您可以递归遍历文件夹和子文件夹）并提供附加命令。

所有Windows 计算机上都有脚本运行时（但 Mac 上没有）。添加对项目的引用只是告诉 VBA 编译器您想要使用它（这称为早期绑定）。优点是编译器可以在编译时为您检查语法，并且在键入代码时您可以获得智能感知的支持。

但是，通过使用 ，您可以完美地摆脱早期绑定CreateObject。这称为后期绑定。编译器对所创建的对象一无所知，如果您访问任何属性或方法，VBA 运行时将查看执行时间（如果存在）。示例：

' Early binding (your current code)
With New FileSystemObject
    If .FileExists(CurrentPathAndName) Then
        .DeleteFile CurrentPathAndName
    End If
End With

VBA 编辑器可以为您提供智能感知，并且编译器会检查方法FileExists和是否DeleteFile存在。如果您输入了拼写错误（例如，您输入了FileExist），编译器可以在代码运行之前向您发出警告。

' Late binding (no reference needed) 
With CreateObject("Scripting.FileSystemObject")
    If .FileExists(CurrentPathAndName) Then
        .DeleteFile CurrentPathAndName
    End If
End With

现在编译器对所创建的对象一无所知，当使用无效的方法名称时，您将收到运行时错误。

这两个版本都可以在存在库的任何计算机上运行，​​而无法在不存在库的任何计算机上运行。但是，当库不存在并且您使用早期绑定时，代码将无法编译，并且您无法使用任何代码。使用后期绑定，您可以使用项目的任何其他代码。

将包含代码的工作簿移动到特定子文件夹

简单呼叫

Sub MoveToOldForecasts()
    MoveFileToSubfolder ThisWorkbook, "OldForecasts"
End Sub

工具

Sub MoveFileToSubfolderRun()
    Dim SubfolderName  As String: SubfolderName = InputBox( _
        Prompt:="Please enter the name of the subfolder", _
        Title:="Move File to Subfolder", _
        Default:="Subfolder Name")
    MoveFileToSubfolder ThisWorkbook, SubfolderName
End Sub

方法

Sub MoveFileToSubfolder(ByVal wb As Workbook, ByVal SubfolderName As String)
    Const PROC_TITLE As String = "Move File to Subfolder"
    On Error GoTo ClearError

    ' Check if no workbook was passed.
    If wb Is Nothing Then
        MsgBox "The workbook was not referenced!", vbExclamation, PROC_TITLE
        Exit Sub
    End If
     
    ' Check if the subfolder name was not supplied.
    If Len(SubfolderName) = 0 Then
        MsgBox "No subfolder supplied!", vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    ' Retrieve the source file name.
    Dim sFileName As String: sFileName = wb.Name

    ' Retrieve the source path.
    Dim sFolderPath As String: sFolderPath = wb.Path
    ' Check if the source file has no path.
    If Len(sFolderPath) = 0 Then
        MsgBox "The file """ & sFileName & """ was never saved!", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
        
    ' Create/reference an instance of the 'Scripting FileSystemObject' object.
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Build the destination file path.
    Dim dFolderPath As String:
    dFolderPath = fso.BuildPath(sFolderPath, SubfolderName)
    
    ' Create the destination folder.
    If Not fso.FolderExists(dFolderPath) Then
        On Error Resume Next
            fso.CreateFolder dFolderPath
        On Error GoTo ClearError
        ' Check if the destination folder was not created.
        If Not fso.FolderExists(dFolderPath) Then
            MsgBox "Could not create the folder """ & SubfolderName _
                & """ in """ & sFolderPath & """.", _
                vbExclamation, PROC_TITLE
            Exit Sub
        End If
    End If
    
    ' Build the destination file name and path.
    Dim dFileName As String: dFileName = fso.GetBaseName(sFileName) & ".xlsm"
    Dim dFilePath As String: dFilePath = fso.BuildPath(dFolderPath, dFileName)
    ' Note: Why not simply 'dFilePath = fso.BuildPath(dFilePath, sFileName)'?
    '       Because 'ThisWorkbook' could be e.g. a '.xls' or '.xlsb' file.
    '       It could even be e.g. a '.xlsx' file where the code
    '       was copied to.
        
    ' Retrieve the source file path.
    Dim sFilePath As String: sFilePath = wb.FullName
        
    ' Save the file to the destination folder.
    On Error Resume Next
        Application.DisplayAlerts = False
        ' The line above enables overwriting with no confirmation and prevents
        ' the appearance of the dialog when saving in a different file format.
            wb.SaveAs Filename:=dFilePath, _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        Application.DisplayAlerts = True
    On Error GoTo ClearError
    ' Check if the file was not saved.
    If Not fso.FileExists(dFilePath) Then
        MsgBox "Could not save the file as """ & dFilePath & """!", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
    ' Note: At this point the 'wb' variable points to the destination file.
    Debug.Print wb.Name, wb.Path ' the proof
    
    ' Delete the source file.
    On Error Resume Next
        fso.GetFile(sFilePath).Delete
    On Error GoTo ClearError
    ' Check if the source file was not deleted.
    Dim WasSourceDeleted As Boolean: WasSourceDeleted = True
    If fso.FileExists(sFilePath) Then WasSourceDeleted = False
    
    ' Inform.
    If WasSourceDeleted Then
        MsgBox "The file" & vbLf & vbLf & """" & sFilePath & """" & vbLf _
            & "was moved to" & vbLf & vbLf & """" & dFilePath & """.", _
            vbInformation, PROC_TITLE
    Else
        MsgBox "The file" & vbLf & vbLf & """" & sFilePath & """" & vbLf _
            & "was moved to" & vbLf & vbLf & """" & dFilePath & """." _
            & vbLf & vbLf & "Could not delete the source file """ & sFilePath _
            & """!", vbExclamation, PROC_TITLE
    End If
    
ProcExit:
    Exit Sub
ClearError:
    MsgBox "Run-time error [" & Err.Number & "]:" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub