Question

我有一个工作簿，我通过我录制的宏格式化。宏当前重命名文件并将其保存到常量路径，但我需要它重命名文件并将其保存到相对路径，以便其他队友可以使用它。有什么建议吗？

这是活动文件

Windows("Manual Reconciliation Template.xlsm").Activate

这是常数路径

ActiveWorkbook.SaveAs FileName:= _
        "C:\Users\e6y550m\Documents\MANUAL RECS\Manual Reconciliation Template.xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

当前代码：

Sub Name_And_Save_Report()
'
' TO NAME, DATE AND SAVE THE REPORT AFTER IT HAS BEEN WORKED.
'
    Windows("Manual Reconciliation Template.xlsm").Activate
    Dim thisWb As Workbook
    Dim fname

    fname = InputBox("Enter your name (example-John):")    
    Set thisWb = ActiveWorkbook
    Workbooks.Add
    ActiveWorkbook.SaveAs FileName:=thisWb.Path & "\" & fname & "_Manual Recon" & " " & Format(Date, "MM.DD.YY") & ".xlsx"
    ActiveWorkbook.Close savechanges:=False
    Windows("Manual Reconciliation Template.xlsm").Activate
    ActiveWorkbook.Close savechanges:=False
End Sub

Answer 1

因此，您将在每个人员文件夹中粘贴包含上述代码的工作簿的副本。当他们打开工作簿时，您希望将其重命名为：
＆LT;＆LT;人名＆gt;＆gt; _Manual Recon ＆lt;＆lt; mm.dd.yy＆gt;＆gt; .xlsx

我假设您希望原始文件留在那里，以便他们可以打开它并在第二天创建新的xlsx，但如果文件已经存在则不创建文件（如果他们在一天内打开xlsm两次）。

需要考虑的另一点是 - 他们的个人文件夹名称是什么？例如。 G:\MMS Trade Payables\John

我注意到在您的代码中，您将变量thisWb设置为等于ActiveWorkbook 您可以使用ThisWorkbook，它始终引用运行代码的工作簿。

因此，使用这些假设，请尝试以下代码：

Sub Name_And_Save_Report()

    Dim fName As String
    Dim sNewFile As String

    'Get the folder name.
    fName = GetParentFolder(ThisWorkbook.Path)

    'Could also get the Windows user name.
    'fName = Environ("username")

    'Or could get the Excel user name.
    'fname = application.username

    'Or could just ask them.
    'fname = InputBox("Enter your name (example-John):")

    sNewFile = ThisWorkbook.Path & Application.PathSeparator & _
        fName & "_Manual Recon " & Format(Date, "mm.dd.yy") & ".xlsx"

    If Not FileExists(sNewFile) Then
        'Turn off alerts otherwise you'll get
        '"The following features cannot be saved in macro-free workbooks...."
        '51 in the SaveAs means save in XLSX format.
        Application.DisplayAlerts = False
        ThisWorkbook.SaveAs sNewFile, 51
        Application.DisplayAlerts = True
    End If

End Sub

Public Function FileExists(ByVal FileName As String) As Boolean
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    FileExists = oFSO.FileExists(FileName)
    Set oFSO = Nothing
End Function

Public Function GetParentFolder(ByVal FilePath As String) As String
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    GetParentFolder = oFSO.GetFolder(FilePath).Name
    Set oFSO = Nothing
End Function

我会把它留在这里作为我的第一个答案：

你的意思是这样的吗？使用FileSystemObject递归获取父文件夹名称。

Sub Test()

    MsgBox ThisWorkbook.Path & vbCr & RelativePath(ThisWorkbook.Path, 2)

    'Will return "C:\Users\e6y550m" - step back 2 folders.
    MsgBox RelativePath("C:\Users\e6y550m\Documents\MANUAL RECS\", 2)

    'Your line of code:
    'ActiveWorkbook.SaveAs FileName:=RelativePath(thisWb.Path, 2) & "\" & fname & "_Manual Recon" & " " & Format(Date, "MM.DD.YY") & ".xlsx"

End Sub

'FilePath - path to file, not including file name.
'GetParent - the number of folders in the path to go back to.
Public Function RelativePath(FilePath As String, Optional GetParent As Long) As String
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    'If rightmost character is "\" then we've reached the root: C:\
    If GetParent = 0 Or Right(FilePath, 1) = Application.PathSeparator Then

        RelativePath = oFSO.GetFolder(FilePath)

        'If we've reached the root then remove the "\".
        If Right(RelativePath, 1) = Application.PathSeparator Then
            RelativePath = Left(RelativePath, Len(RelativePath) - 1)
        End If

    Else

        'GetParent is greater than 0 so call the RelativePath function again with
        'GetParent decreased by 1.
        RelativePath = RelativePath(oFSO.GetParentFolderName(FilePath), GetParent - 1)

    End If
    Set oFSO = Nothing
End Function

Answer 2

如果我的问题不清楚，我道歉;我充其量只是VBA的新手。

＆＃39;这是当前已打开的文件，

Windows("Manual Reconciliation Template.xlsm").Activate

＆＃39;我想与我的队友分享这个文件，以便他们可以使用它。他们都有不同的文件夹。我将在每个文件夹中放置此工作簿的副本。当他们使用个人文件夹中的副本时，宏需要重命名工作簿并将重命名的副本保存在其个人文件夹中。因此，宏需要代码将重命名工作簿并将其保存在其文件夹中，而无需定义路径。共享驱动器路径为G：\ MMS Trade Payables。 MMS Trade Payables文件夹中包含个人文件夹。我认为代码只需要激活已经打开的当前工作簿，重命名它并将其作为.xlsx而不是.xlsm保存在当前文件夹中。

当前代码：

Sub Name_And_Save_Report()
'
' TO NAME, DATE AND SAVE THE REPORT AFTER IT HAS BEEN WORKED.
'
    Windows("Manual Reconciliation Template.xlsm").Activate
    Dim thisWb As Workbook
    Dim fname

' Will use the fname variable to add the associates name to the file name (ex:If the associate enters Mark into the inputbox, fname will = Mark).  
    fname = InputBox("Enter your name (example-John):")  

' Makes thisWb = "Manual Reconciliation Template.xlsm".
    Set thisWb = ActiveWorkbook     
    Workbooks.Add

' Saves the active workbook ("Manual Reconciliation Template.xlsm") to the path of thisWb and renames the workbook by adding the fname value and the current date (ex: if the associate entered Mark as the value of fname, "Manual Reconciliation Template.xlsm" becomes "Mark_Manual Recon 7.14.17.xlsx").
    ActiveWorkbook.SaveAs FileName:=thisWb.Path & "\" & fname & "_Manual Recon" & " " & Format(Date, "MM.DD.YY") & ".xlsx" 

' Closes the renamed workbook.
    ActiveWorkbook.Close savechanges:=False

' Calls the original workbook and closes it.
    Windows("Manual Reconciliation Template.xlsm").Activate
    ActiveWorkbook.Close savechanges:=False
End Sub

当然，这可能是完全错误的，因为我是VBA的新手。

重命名excel文件并将其保存到VBA的相对路径

2 个答案: