[英]vba make folder path universal?
VBA 的新手,并有一项任务是创建一个从一个工作簿粘贴到新工作簿的子。 保存文件的要求是“文件夹路径是通用的,以便其他人也可以创建此文件夹”。 我将对 ActiveWorkbook.SaveAs 方法进行哪些修改来实现这一点? 谢谢
Sub pasteTable()
Dim formatting As Variant 'create variable to hold formatting2 workbook path
formatting = Application.GetOpenFilename() 'user is prompted and selects path to formatting2 workbook and assigns to formatting variable
Workbooks.Open formatting 'formatting2 workbook is now active
Worksheets("Formatting").Range("B3:R13").Copy 'copies table from formatting2 workbook
Workbooks.Add 'add new workbook
Worksheets(1).Range("B3:R13").Select 'selects range on worksheet of new workbook to paste table
Selection.PasteSpecial xlPasteAll 'pastes table
Columns("B:R").ColumnWidth = 20 'ensures table has proper row and column heights/widths
Rows("3:13").RowHeight = 25
Worksheets(1).Name = "Table Data" 'renames worksheet
ActiveWorkbook.SaveAs "C:\Users\name\Desktop\names Excel Assessment VBA\names Excel Assessment VBA " & Format(Date, "dd/mmm/yyyy"), FileFormat:=xlOpenXMLWorkbookMacroEnabled
'saves workbook according to desired specifications
End Sub
将您的保存行更改为:
ActiveWorkbook.SaveAs "C:\Users\" & Environ("Username") & "\Desktop\Excel Assessment VBA\Excel Assessment VBA " & Format(Date, "dd-mmm-yyyy") & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Username
名系统变量将根据谁在使用它进行调整。 只需确保每个用户的桌面上也存在这些文件夹,否则您将收到错误消息。 我还从文件夹names
中删除了名称,因为我假设您也试图用那里的用户名做一些事情。 您可以根据自己的需要进行调整。
您的日期格式也需要更改,因为它包含非法字符。
您还忘记了包含文件扩展名,所以我也添加了它。
这条线发生了很多事情,包括很多错误,所以你将不得不稍微尝试一下,直到你得到你需要的东西。 你可能想稍微简化一下,直到你掌握了所有这些事情的窍门。
我认为您必须添加更多检查
该脚本期望工具路径文件夹的名称为常量ToolFolder
。
加上第二个常量ToolBaseFolder
,可以设置为父路径`ToolFolder,例如网络路径。 如果 const 为空,将使用用户桌面。
如果此路径尚不存在,则将创建它。
Option Explicit
Private Const ToolBaseFolder As String = "" 'if ToolBaseFolder is an empty string desktop will be used instead
Private Const ToolFolder As String = "MyNameForToolFolder"
Public Sub testWbToToolFolder()
'this is just for testing
Dim wb As Workbook: Set wb = ActiveWorkbook
saveWbToToolFolder wb, "test.xlsx"
End Sub
Public Sub saveWbToToolFolder(wb As Workbook, filename As String)
'you don't need this sub - but have the same code line in your main routine
wb.SaveAs getToolFolder & filename
End Sub
Public Function getToolFolder() As String
'this returns the toolfolder e.g. C:\Users\xyz\Desktop\MyNameForToolFolder
Dim basepath As String
basepath = ToolBaseFolder & "\"
If existsFolder(basepath) = False Then
If LenB(ToolBaseFolder) > 0 Then
MsgBox ToolBaseFolder & " does not exist." & vbCrLf & _
"File will be saved to " & ToolFolder & " on desktop ", vbExclamation
End If
basepath = getDesktopFolderOfUser
End If
Dim fullpath As String
fullpath = basepath & ToolFolder & "\"
If existsFolder(fullpath) = False Then
makeFolder fullpath
End If
getToolFolder = fullpath
End Function
Private Function existsFolder(path As String) As Boolean
If Len(path) < 2 Then Exit Function 'can't be a valid folder
existsFolder = LenB(Dir(path, vbDirectory)) > 0
End Function
Private Function getDesktopFolderOfUser() As String
getDesktopFolderOfUser = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
End Function
Private Function makeFolder(path As String)
'https://stackoverflow.com/a/26934834/16578424 plus comment from rayzinnz
CreateObject("WScript.Shell").Run "cmd /c mkdir """ & path & """", 0, True
End Function
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.