Menu
  1. Accueil
  2. Tech Forum
  3. Office Software
  4. Excel

Modified code create subfolder and save as pdf to it based on cell [Solved]

Report
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021
 -
Posts
2717
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
April 1, 2021
 -
hi, all
i need help to amend my code actually the code works very well but i need some adjusting i would create subfolders based on h2 then save as pdf file name based on i2 so the file pdf will save to subfolder based on h2 then when i run macro every time if the subfolder name is existed then just copy to file name to existed subfolder if not existed then create a new subfolder based on h2 and save the file to it and if i run macro a gain to save file name to subfolder and the same file is existed then gives me message if i replace the file or not 
Sub SavePDF()
    ChDir "C:\Users\OSE\Downloads\client\" & ActiveSheet.Range("H2").Value & "\"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveSheet.Range("i2") _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False
End Sub

thanks

1 reply

Answer 1 / 1
Posts
2717
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
April 1, 2021
 458
Hi Abdel,

Here you go: 
Sub RunMe()
Dim mPath, mPathFile As String
Dim oW As Long

mPath = "C:\Users\OSE\Downloads\client\" & ActiveSheet.Range("H2").Value & "\"
mPathFile = mPath & ActiveSheet.Range("I2").Value

If Dir(mPath, vbDirectory) = vbNullString Then
    MkDir mPath
    GoTo sFile
End If

If CBool(Len(Dir$(mPathFile & ".pdf")) > 0) = True Then
    oW = MsgBox("Overwrite existing file?", vbQuestion + vbYesNo, "File Exists")
    If oW = vbYes Then
        GoTo sFile
    Else
        Exit Sub
    End If
Else
    GoTo sFile
End If
Exit Sub

sFile:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=mPathFile _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End Sub


NOTE: I did assume you don't have the ".pdf" extention added to your filename in cell I2. If you do, then remove the "& ".pdf" part on code line 13.

Best regards,
Trowa

Report
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021
many thanks ,Trowa it works so well can you add message box if cell h2 or i2 are empty then show message "you have to fill names subfolder and file "? i noted it gives me error if are two or one of them empty
thanks again
Report
Posts
2717
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
April 1, 2021
 458 >
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021
Hi Abdel,

Good to hear!

To prevent the missing data error, paste the piece of code between code line 3 and 5: 
If Range("H2").Value = vbNullString And Range("I2").Value = vbNullString Then
    MsgBox "You have to enter subfolder and file names.", vbInformation, "Missing names"
    Range("H2:I2").Select
    Exit Sub
ElseIf Range("H2").Value = vbNullString Then
    MsgBox "You have to enter subfolder name.", vbInformation, "Missing name"
    Range("H2").Select
    Exit Sub
ElseIf Range("I2").Value = vbNullString Then
    MsgBox "You have to enter file name.", vbInformation, "Missing name"
    Range("I2").Select
    Exit Sub
End If


Best regards,
Trowa
Report
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021
 >
Posts
2717
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
April 1, 2021
astonishing updating i appreciate your assistance the code has become more efficient thanks for every thing
best regards,
abdelfattah
Report
Posts
2717
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
April 1, 2021
 458 >
Posts
69
Registration date
Thursday July 18, 2019
Status
Member
Last seen
January 15, 2021
Awesome Abdel! Thanks for the kind feedback!
Reply Ask a question

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!