时间戳

首页 > 解决方案 > 如何通过在文件路径中创建新文件夹来自动保存

excel - 如何通过在文件路径中创建新文件夹来自动保存

问题描述

根据我在网站上找到的代码，我创建了一个宏，用于将 Excel 工作簿中的工作表导出为 PDF 附件到电子邮件。基于其他代码，我设法创建了一个文件夹的自动保存，但现在保存是硬编码的。请参阅下面的代码，我对代码有 3 个问题。

  1. 现在保存位置被硬编码到宏中。如何调整宏以使用我打开文件的位置作为自动保存位置？我主要需要它是动态的，因为我们会将这个文件复制到一个新的文件夹月份，它不能被硬编码。
  2. 我希望宏检查保存位置中是否存在单独的文件夹，如果不为它创建一个文件夹。所以基本上，我会从文件夹 C:\User:\CompanyDrive:\Client:\January2020 打开文件，我希望宏检查这个文件夹是否包含另一个文件夹，如 C:\User:\CompanyDrive:\Client: \January2020:\Individual Exports，如果不存在，则创建一个。
  3. 保存时有没有办法避免使用 SharePoint 路径？我们使用公司 OneDrive/SharePoint 本地同步来打开文档，但它会自动转换为 SharePoint 文档并尝试保存到 SharePoint。但是，我们总是上传失败，所以我想知道如何避免这种情况？

提前致谢！

请参见下面的代码：

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xPath As String
Dim NameOfWorkbook

NameOfWorkbook = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))

Dim myPath As String
Dim folderPath As String

folderPath = Application.ActiveWorkbook.Path
myPath = Application.ActiveWorkbook.FullName

Set xSht = ActiveSheet
xPath = "C:\User:\CompanyDrive:\Client:\January2020:\Individual Exports" 'here "Individual Exports" is the destination folder to save the pdf files
xFolder = xPath + "\" + NameOfWorkbook + " " + xSht.Name + ".pdf"
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If
 
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
     
    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = ""
        .CC = ""
        .Subject = NameOfWorkbook + " " + xSht.Name
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub

标签： excelvbasharepointautosave

解决方案

  folderPath = Application.ActiveWorkbook.Path
  myPath = Application.ActiveWorkbook.FullName

  Set xSht = ActiveSheet

  '1. use the location where I open the file from as autosave location
  xFolder = folderPath + "\" + NameOfWorkbook + " " + xSht.Name + ".pdf"
  '2. create folder in save location if it doesn't exist
  Const SubFolder = "Individual Exports"
  Dim sPath As String
  sPath = folderPath & Application.PathSeparator & SubFolder
  If Len(Dir(sPath, vbDirectory)) = 0 Then
    MkDir sPath
  End If

推荐阅读