將工作表保存到 PDF 並在需要時創建一個目錄，適用於 Windows 和 MacOS

Question

我在這里有點修復，因為這段代碼非常適合 windows [我自己的操作系統]。 代碼的目的是每次都將特定的工作表保存在文件名中。 如果目錄不存在，它還會創建目錄來存儲文件名。

但是，當在 MacOS 上嘗試時，它只會產生錯誤。 沒有創建或保存 PDF。 它只是設法突出顯示要保存到 PDF 的區域。僅此而已。

有任何想法嗎？

Sub SaveSelectionAsPDF()

Dim saveLocation As String
Dim CheckOS, PoNumber As String
Dim RememberFirstRow, RememberLastRow As Integer
Dim saveDirectory As String


Worksheets("PO_Formatted").Activate
CheckOS = Application.OperatingSystem
PoNumber = Cells(11, 3).Value

If InStr(1, CheckOS, "Windows") > 0 Then

saveDirectory = "C:\Users\" & Environ("username") & "\Desktop\PO Sheets\" & Format(Date, "dd-mmm-yyyy") & "\"
saveLocation = "C:\Users\" & Environ("username") & "\Desktop\PO Sheets\" & Format(Date, "dd-mmm-yyyy") & "\" & Cells(11, 3).Value & ".pdf"

Call CreateDir(saveDirectory)



Else

saveLocation = "/Users/username/Desktop/" & Cells(11, 3).Value & ".pdf"

End If

    Range("B1000").Select
    Selection.End(xlUp).Select
    Range(ActiveCell.Offset(1, -1), Cells(1, 10)).Select

Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=saveLocation, OpenAfterPublish:=True

Worksheets("PO_Sheet").Activate
For i = 4 To ActiveSheet.UsedRange.Rows.Count
    If Cells(i, 4).Value = PoNumber Then
        Cells(i, 21).Value = "Confirmed"
    End If
Next i

Worksheets("PO_Formatted").Activate
End Sub



Sub CreateDir(strPath As String)
    Dim elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each elm In Split(strPath, "\")
        strCheckPath = strCheckPath & elm & "\"
        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
    Next

End Sub

所以它在 Windows 上完美運行，但在 MacOS 上運行不正常，它只會產生錯誤。 沒有創建或保存 PDF。 它只是設法突出顯示要保存到 PDF 的區域。僅此而已。

Answer 1

對於 Windows 和 MacOS，導出范圍為 PDF

• 我沒有 Mac，所以歡迎任何反饋。

Option Explicit

Sub ExportRangeToPDF()

    Dim pSep As String: pSep = Application.PathSeparator
    
    Dim FolderPath As String: FolderPath = Environ("USERPROFILE") _
        & pSep & "Desktop" & pSep & "PO Sheets" & pSep _
        & Format(Date, "dd-mmm-yyyy")
    CreateFolder FolderPath
    'ThisWorkbook.FollowHyperlink FolderPath ' explore the folder
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim fws As Worksheet: Set fws = wb.Sheets("PO_Formatted")
    Dim frg As Range: Set frg = fws.Range("J1", _
         fws.Cells(fws.Rows.Count, "B").End(xlUp).Offset(1, -1)) ' ? 1 = 0 ?
    
    Dim PoNumber As String: PoNumber = fws.Range("C11").Value
    Dim FilePath As String: FilePath = FolderPath & pSep & PoNumber & ".pdf"
    
    frg.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FilePath, _
        OpenAfterPublish:=True
    
    Dim sws As Worksheet: Set sws = wb.Sheets("PO_Sheet")
    
    Dim r As Long
    
    For r = 4 To sws.UsedRange.Rows.Count
        If CStr(sws.Cells(r, "D").Value) = PoNumber Then
            sws.Cells(r, "U").Value = "Confirmed"
        End If
    Next r
    
    MsgBox "Range exported to PDF.", vbInformation
    
End Sub

創建文件夾

Sub CreateFolder(ByVal FolderPath As String)

    Dim pSep As String: pSep = Application.PathSeparator
    
    Do While Right(FolderPath, 1) = pSep ' remove trailing path separators
        FolderPath = Left(FolderPath, Len(FolderPath) - 1)
    Loop
    
    Dim SplitPath() As String: SplitPath = Split(FolderPath, pSep)
    
    Dim n As Long, JoinedPath As String
    
    Do While Len(SplitPath(n)) = 0 ' handle leading path separators
        JoinedPath = JoinedPath & pSep
        n = n + 1
    Loop
  
    For n = n To UBound(SplitPath)
        JoinedPath = JoinedPath & SplitPath(n) & pSep
        If Len(Dir(JoinedPath, vbDirectory)) = 0 Then MkDir JoinedPath
    Next

End Sub