Excelファイルの名前を変更してVBAを使用して相対パスに保存

Question

記録したマクロを使用してフォーマットするブックがあります。マクロは現在、ファイルの名前を変更して一定のパスに保存しますが、ファイルの名前を変更して相対パスに保存して、他のチームメイトが使用できるようにする必要があります。提案はありますか？

これはこれは、一定のパス

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

現在のコードでアクティブなファイル

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

です：だから

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

、あなたが含むワークブックのコピーを貼り付けます各人物のフォルダに上記のコード。彼らはあなたがそれのように自身の名前を変更したいブックを開くとき：
< <人物名>> _Manual偵察< < MM.DD.YY >>の.xlsx

を私はあなたが左に元のファイルをしたいと仮定しますそのファイルを開いて翌日の新しいxlsxを作成することはできますが、すでに存在する場合はファイルを作成しません（xlsmを1日に2回開く場合）。

もう1つのポイントは、名前が付けられた個人用フォルダですか？
など。 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の初心者です。

「これはすでに開いている現在のファイルであり、

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

」私は、彼らはそれを使用することができますので、私のチームメイトで、このファイルを共有したいです。彼らはすべて異なるフォルダを持っています。このブックのコピーをそれぞれのフォルダに配置します。個人用フォルダにあるコピーを使用する場合、マクロはブックの名前を変更し、名前を変更したコピーを個人用フォルダに保存する必要があります。したがって、マクロには、ブックの名前を変更し、定義されたパスを持たずにフォルダに保存するコードが必要です。共有ドライブのパスはG：\ MMSの買掛金です。 MMS Trade Payablesフォルダには個人用のフォルダがあります。私はコードがすでに開いている現在のブックをアクティブにする必要があると思う、名前を変更し、.xlsmの代わりに.xlsxとして現在のフォルダに保存する必要があります。

現在のコード：私はVBAに新しいですので、もちろん

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 

、これは完全に間違っている可能性があります。