因此，您将在每个个人文件夹中粘贴包含上述代码的工作簿副本。当他们打开工作簿时，您希望它重命名为：
>_Manual Recon >.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