Create A Folder Directory in Excel using Visual Basic - vba

I am extremely new to Visual Basic
I am currently trying to create a calculator within excel that I can export the data within to a PDF. I have been able to export the excel document however it is only going to my "D:\".
How do I create a folder within D:\ called something like Excel_Calculator where I can have all the PDF's created be saved directly into that folder & If there already is a folder called "Excel_Calculator" to use that folder instead of overwriting the existing folder.
The code I have for saving the PDF is listed here:
Sub GetFilenameForPDF()
Dim strFileName As String, strB1 As String, strWorksheet As String
strB1 = Range("B1").Value
strWorksheet = ActiveSheet.Name
strFileName = strB1 & " " & strWorksheet & " " & Format(Date, "DD-MM-YYYY")
Sub SaveToPDF()
Dim strFileName As String, strC3 As String, strWorksheet As String
strB1 = Range("B1").Value
strWorksheet = ActiveSheet.Name
strFileName = strB1 & " " & strWorksheet & " " & Format(Date, "DD-MM-YYYY")
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"D:\" & strFileName & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
End Sub
** EDIT: Or is there a way I can create or redirect the files to a temporary location so that the folder isn't clogged up and the user can print/save the PDF when needed?**

I prefer using the FileSystemObject
In your VBA project, click Toos->References and add "Microsoft Scripting Runtime".
Then, in your code, do something like:
Dim fso as FileSystemObject
Dim folderName as String
Set fso = new FileSystemObject
folderName = "D:\MyFolder"
If fso.FolderExists(folderName) = false then
fso.CreateFolder folderName
End If
Dim strFileName As String, strC3 As String, strWorksheet As String
strB1 = Range("B1").Value
strWorksheet = ActiveSheet.Name
strFileName = folderName + "\" + strB1 & " " & strWorksheet & " " & Format(Date, "DD-MM-YYYY")
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"D:\" & strFileName & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True

You can use the function below to create a single folder or a tree of subfolders. The function uses the (VBA.FileSystem) MkDir function.
Public Function CreateFolderTree(ByVal mainFolder As String, ParamArray args() As Variant) As String
On Error GoTo ErrProc
Dim path As String
path = mainFolder & IIf(Right(mainFolder, 1) <> "\", "\", vbNullString)
Dim idx As Long
For idx = LBound(args) To UBound(args)
If Len(Dir(path & args(idx), vbDirectory)) = 0 Then MkDir path & args(idx)
path = path & args(idx) & "\"
Next idx
CreateFolderTree = path
Leave:
On Error GoTo 0
Exit Function
ErrProc:
MsgBox Err.Description, vbCritical
Resume Leave
End Function
To call it:
Sub T()
Dim path_ As String
path_ = CreateFolderTree("C:\My folder", "Subfolder 1", "Subfolder 2")
Debug.Print path_
'C:\My folder\Subfolder 1\Subfolder 2\
End Sub

I usually use this:
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Public Sub MakeFullDir(strPath As String)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\" 'Optional depending upon intent
MakeSureDirectoryPathExists strPath
End Sub
If the path doesn't already exists, it creates it, even if there are multiple layer of non-existing folders.
E.g: C:\aFolder\bFolder\cFolder\ if only aFolder exists this will make bFolder and cFolder.

Related

VBA Excel Ignores PrintArea Pdf

I have 250 excel documents where I try to print a sheet for pdf. If I do it manually, it will be 4 pages, but if I use my code, it will be 7 pages long.
It's like it ignores the print area, and makes several blank pages.
Can any of you figure out the mistake?
Dim wb As Workbook
Dim xExtension As String: xExtension = "*.xls*"
Dim xFolder As String: xFolder = [MailFolder]
Dim xFile As String: xFile = Dir(xFolder & xExtension) 'DIR gets the first file of the folder
Dim Rng As Range: Set Rng = Range("A1")
Dim s As String
Do While xFile <> "" 'Loop through all files in a folder until DIR cannot find anymore
Set wb = Workbooks.Open(xFolder & xFile): wb.Activate
Call WorksheetsToPDF(wb, "F:\VBA\PDF\Udlejning\" & CleanFileName("Police - " & "2021 -" & [KompletPoliceNr] & " - " & [Forsikringstager]) & ".pdf", "Certifikat")
'Call WorksheetsToPDF(wb, "F:\VBA\KF Begæringer\" & CleanFileName("KF Begæring-2021-" & [KompletPoliceNr] & "-" & [Forsikringstager]) & ".pdf", "Police")
wb.Close savechanges:=False
xFile = Dir()
Loop
End Sub
Private Sub WorksheetsToPDF(wb As Workbook, DistinationPath As String, ParamArray Arr() As Variant)
wb.Sheets(Arr()).Select
Debug.Print EFDK.GetNextavailablefilename(DistinationPath)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=EFDK.GetNextavailablefilename(DistinationPath), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
End Sub
Private Function GetNextAvailableFilename(ByVal xPath As String) As String
With CreateObject("Scripting.FileSystemObject")
Dim strFolder As String, strBaseName As String, strExt As String, i As Long
strFolder = .GetParentFolderName(xPath)
strBaseName = .GetBaseName(xPath)
strExt = .GetExtensionName(xPath)
Do While .FileExists(xPath)
i = i + 1
xPath = .BuildPath(strFolder, strBaseName & " - " & i & "." & strExt)
Loop
End With
GetNextAvailableFilename = xPath
End Function
You did not answer my clarification questions...
Just for the sake of testing, please try the next adapted function:
Private Sub WorksheetsToPDF(wb As Workbook, DistinationPath As String, ParamArray arr() As Variant)
Dim El
wb.Sheets(arr()).Select
For Each El In arr()
wb.Sheets(El).PageSetup.FitToPagesWide = 1
wb.Sheets(El).PageSetup.PaperSize = xlPaperA4 ' xlPaperLetter
wb.Sheets(El).PageSetup.Orientation = xlLandscape
Next
'Debug.Print EFDK.GetNextavailablefilename(DistinationPath)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=EFDK.GetNextavailablefilename(DistinationPath), Quality:=xlQualityStandard, IncludeDocProperties:=True
End Sub

VBA to Create a Folder and Save as a pdf within the folder

i'm very new to VBA and have an issue.
I've received help in saving a file into a specific folder but not allowing me to overwrite the file.
Sub Autosave2()
Dim vDir
Dim strFileExists, pdfname, fileSaveName As String
Dim FSO
pdfname = ActiveSheet.Range("Q2")
vDir = "\\Reports\Internal PO Log\PO pdf's\"
If Right(pdfname, 3) = "pdf" Then
fileSaveName = vDir & pdfname
Else
fileSaveName = vDir & pdfname & ".pdf"
End If
MsgBox fileSaveName
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FileExists(fileSaveName) Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fileSaveName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
MsgBox "PDF File Saved (CentreSoft\Reports\Internal PO Log\PO pdf's)"
Else
MsgBox "THIS PO NUMBER ALREADY EXISTS"
End If
End Sub
I now need to create a folder with the same name (Range("Q2")) and save the file as a pdf within the new folder (with the same name; PO number in this scenario)
I also need to display messages should the folder already exits thus blocking the code from running any further.
Any help would be hugely appreciated
Thanks
Is this what you want?
Sub Autosave2()
Dim vDir
Dim strFileExists, pdfname, fileSaveName As String
Dim separator As String: separator = Application.PathSeparator
Dim FSO
pdfname = ActiveSheet.Range("Q2")
vDir = "\\Reports\Internal PO Log\" & pdfname
If Dir(vDir, vbDirectory) = "" Then
'create folder
MkDir vDir
Else
MsgBox "The folder already exits thus blocking the code from running any further."
Exit Sub
End If
If Right(pdfname, 3) = "pdf" Then
fileSaveName = vDir & separator & pdfname
Else
fileSaveName = vDir & separator & pdfname & ".pdf"
End If
'MsgBox fileSaveName
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FileExists(fileSaveName) Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=fileSaveName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
MsgBox "PDF File Saved in " & vDir
Else
MsgBox "THIS PO NUMBER ALREADY EXISTS"
End If
End Sub
I've solved it :-)
Sub Autosave2()
Dim vDir
Dim strFileExists, pdfname, fileSaveName As String
Dim FSO
Dim FldrName As String
pdfname = ActiveSheet.Range("Q2")
FldrName = "\\Reports\Internal PO Log\PO pdf's\" & pdfname & "\" & pdfname
vDir = "\\Reports\Internal PO Log\PO pdf's\" & pdfname
If Dir(vDir, vbDirectory) = "" Then
'continue
Else
MsgBox "The folder already exits thus blocking the code from running any further."
Exit Sub
End If
'create folder
MkDir vDir
If Right(pdfname, 3) = "pdf" Then
fileSaveName = FldrName & ".pdf"
Else
fileSaveName = FldrName & ".pdf"
End If
'MsgBox fileSaveName
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FileExists(fileSaveName) Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fileSaveName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
MsgBox "PDF File Saved in " & vDir
Else
MsgBox "THIS PO NUMBER ALREADY EXISTS"
End If
End Sub
Not too sure if it's the best work around but i've created a new FldrName and pointed everything towards that in the file save
Thanks so much for getting me that far.....you've been a great help

Saving files to directory and subdirectory

I am trying to save a file based on cell value in a directory and sub-directory based on cell values. The goal is for the code to check to see if the directory and sub-directory are present and then create the folders if necessary. Can someone show me and explain how I can alter this code to make the sub-directory?
This code is for checking/creating the first directory and saving the file within it.
Sub Macro4()
Dim strFilename, strDirname, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
strDirname = Worksheets("Private").Range("M2").Value ' New directory name
strFilename = Worksheets("Sheet2").Range("C1").Value 'New file name
strDefpath = Environ("USERPROFILE") & "\Documents\Folder1\" & Worksheets("Private").Range("L2").Value 'Default path name"
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub
MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
This is what I've tried to make a sub-directory in addition to the initial directory.
Sub Macro4()
Dim strFilename, strDirname, strDir2name, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
strDirname = Worksheets("Private").Range("L2").Value 'New directory name
strDir2name = Worksheets("Private").Range("M2").Value ' New directory 2 name
strFilename = Worksheets("Sheet2").Range("C1").Value 'New file name
strDefpath = Environ("USERPROFILE") & "\Documents\Folder1" 'Default path name"
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strDir2name) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub
MkDir strDefpath & "\" & strDirname & "\" & strDir2name
strPathname = strDefpath & "\" & strDirname & "\" & strDir2name & "\" & strFilename 'create total string
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
If you can get a directory you wish to save in, as a String, you can use the two below:
Sub Test()
Dim myDir as String
myDir = "C:\Users\Beedle\MyFolder\subFolder\"
MyMkDir myDir
' Now you can save/do whatever with myDir.
End Sub
And the sub, which will create all necessary folders. (So if you just have C:\Users\Beedle, it'll create MyFolder and subFolder in MyFolder:
Public Sub MyMkDir(sPath As String)
'https://www.devhut.net/2011/09/15/vba-create-directory-structurecreate-multiple-directories/
Dim iStart As Integer
Dim aDirs As Variant
Dim sCurDir As String
Dim i As Integer
If sPath <> "" Then
aDirs = Split(sPath, "\")
If Left(sPath, 2) = "\\" Then
iStart = 3
Else
iStart = 1
End If
sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
For i = iStart To UBound(aDirs)
sCurDir = sCurDir & aDirs(i) & "\"
If Dir(sCurDir, vbDirectory) = vbNullString Then
MkDir sCurDir
End If
Next i
End If
End Sub

VBA code to save PDF does not work properly

I have set up a command button to save the current worksheet as a PDF file. I have played around with this code for several hours and almost got it to work properly but it seems I have disconnected some areas and cannot find my way back. Please see below for the code that I am using and the variables I am having an issue with at this point. Any help or information would be much appreciated! Thanks in advance!
Issues:
When you click 'Cancel' in the save application box, the document still tries to save.
If the file already exists:
Selecting 'Yes' to over-write does not save the document.
Selecting 'No' to over-write and renaming as another already existing document does not prompt another Question box to over-write or not. It simply over-writes the original document name.
Sub PDFFHA()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strPath = "I:\OCC FRB REMIC Reporting\Quality Control\PDFs"
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
strName = Replace(wsA.Range("D3"), " ", "")
strName = Replace(strName, ".", "_")
strFile = "FHA" & "_" & strName & "_" & "QC" & ".pdf"
strPathFile = strPath & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If bFileExists(strPathFile) Then
lOver = MsgBox("Overwrite existing file?", _
vbQuestion + vbYesNo, "File Exists")
If lOver <> vbYes Then
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF file has been created: " _
& vbCrLf _
& strPathFile
Else
GoTo exitHandler
End If
End If
Else
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF file has been created: " _
& vbCrLf _
& strPathFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
'=============================
Function bFileExists(rsFullPath As String) As Boolean
bFileExists = CBool(Len(Dir$(rsFullPath)) > 0)
End Function
'=============================
With some clean-up and re-formatting.
If the file already exists, you are prompted to overwrite or not. The code only checks for the response to be vbNo since vbYes implies that strPathFile remains the same, i.e. no action needed. The loop handles a Cancel click, as well as the possibility that your new strPathFile is again an existing file.
Option Explicit
Sub PDF_FHA()
Dim wsA As Worksheet: Set wsA = ActiveWorkbook.ActiveSheet
Dim strName, strPath, strFile, strPathFile As String
On Error GoTo errHandler
' Get path
strPath = "I:\OCC FRB REMIC Reporting\Quality Control\PDFs\"
' Get and clean filename
strName = Replace(wsA.Range("D3"), " ", "")
strName = Replace(strName, ".", "_")
strFile = "FHA_" & strName & "_QC.pdf"
strPathFile = strPath & strFile
' Check if file exists, prompt overwrite
If bFileExists(strPathFile) Then
If MsgBox("Overwrite existing file?", _
vbQuestion + vbYesNo, "File Exists") = vbNo Then
Do
strPathFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
' Handle cancel
If strPathFile = "False" Then Exit Sub
' Loop if new filename still exists
Loop While bFileExists(strPathFile)
End If
End If
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox "PDF file has been created: " _
& vbCrLf _
& strPathFile
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
End Sub
'=============================
Function bFileExists(rsFullPath As String) As Boolean
bFileExists = CBool(Len(Dir$(rsFullPath)) > 0)
End Function
'=============================
Firstly, turn Option Explicit on.
Follow the logic in If lOver <> vbYes Then. With the proper indenting you will see that it only handles the <> vbYes path and does not have an Else.
So, you do not actually handle the "Yes" case.
Your "No" logic only brings up a file dialog box and we don't know what you have done to test this (cancel, put new name in, just accept name as presented?). However, there is no additional question on this logic path. If you don't hit "Cancel" to the file dialog it will just save the file.

Save each worksheet in workbook as an individual pdf

I want to loop over all worksheets in a workbook and save them as individual pdfs in the same path as the workbook. The files are named after the worksheet name.
This code below works up until the "wsA.ExportAsFixedFort" line. The error message i get is:
Run-time error '91': Object variable or With block variable not set
But i cant figure out what the issue is...
Any suggestions?
Option Explicit
Sub WorksheetLoop()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim WS_Count As Integer
Dim I As Integer
' Set WS_Count equal to the number of worksheets in the active workbook.
Set wbA = ActiveWorkbook
WS_Count = wbA.Worksheets.Count
strPath = wbA.Path
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
' Begin the loop.
For I = 1 To WS_Count
'replace spaces and periods in sheet name
strName = Replace(wbA.Worksheets(I).Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
myFile = strPath & strFile
Debug.Print myFile
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
Next I
End Sub
Try to change like this:
If myFile <> "False" Then
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Then try to find a way how to loop through the sheets, its a trivial VBA task.
In general, in your code wsA was not set. Thus, you got an error.