I am trying to write some code that will save several tabs as a pdf document in folder specified by files within excell. I would like for cells within the document to dictate where this file is saved. I am not sure if this is possibly, but if it is any help would be good! I am currently getting a Run-time error '1004' during the save process of my code.
And yes, I do have the folders created that are being referenced.
Sub asdf()
Dim Fname As String
Dim Fpath As String
Dim YrMth As String
Fname = Sheets("Sheet1").Range("A1").Text
YrMth = Sheets("Sheet1").Range("A2").Text & "\" & Sheets("Sheet1").Range("A3").Text
Fpath = "C:\Documents and Settings\My Documents\" & YrMth & "\Group\" & Fname & ".pdf"
ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet4")).Select
Application.DisplayAlerts = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fpath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
Your code works for me, but not with the path you've specified.
Declare a new string variable:
dim myDocsPath as String
Get the path using:
myDocsPath = Environ$("USERPROFILE") & "\My Documents\"
and then change your definition for Fpath to:
Fpath = myDocsPath & YrMth & "\Group\" & Fname & ".pdf"
If I change the end of myDocsPath to & "\My foo Documents\" I get the same 1004 error you are getting.
Try replace line in your code
Fpath = "C:\Documents and Settings\My Documents\" & YrMth & "\Group\" & Fname & ".pdf"
with
Dim WshShell As Object
Dim MyDocsFolder As String
Set WshShell = CreateObject("WScript.Shell")
MyDocsFolder = WshShell.SpecialFolders("MyDocuments") & "\"
Fpath = MyDocsFolder & YrMth & "\Group\" & Fname & ".pdf"
Edit:
The core of this solution is in line:
MyDocsFolder = WshShell.SpecialFolders("MyDocuments") & "\"
which returns system path to My Documents, irrespectively from local system settings like language or nonstandard location of My Documents folders. Then it adds a backslash at the end.
It is more elegant (and the code becomes more portable) if you ask system about special folders than hardcode such data in your script.
More on Windows special folders in VBA you can find https://www.rondebruin.nl/win/s3/win027.htm
Related
With no coding knowledge, I have attempted to use some code found here: Automatically name a file based on cell data when saving a spreadsheet?. Thanks to Jean-François Corbett
I have adapted as follows to show the dialog box:
Sub SaveAsString()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "N:\PROJECTS\"
strPath = strFolderPath & _
Sheet1.Range("B2").Value & "_" & _
Sheet1.Range("B6").Value & "_" & _
Sheet1.Range("X1").Value & "-JS-1" & ".xlsm"
Application.Dialogs(xlDialogSaveAs).Show strPath
ActiveWorkbook.SaveAs FileFormat:=xlOpenXMLWorkbookMacroEnabled
End Sub
I am opening an .xltm file, and attempting to save with the ability to select the subfolder of N:\PROJECTS\ with the combination of cell references shown.
The dialog box appears fine, already showing N:\PROJECTS. However, it does not fill the file name, unless the file is first saved as a .xlsm. It then always attempts to overwrite as well.
This worked for me, utilizing a slightly different code technique.
Option Explicit
Sub SaveAsString()
Dim strPath As String
Dim strFolderPath As String
ChDir "N:\PROJECTS\" 'set directory with this line
With Sheet1
strPath = .Range("B2").Value
strPath = strPath & "_" & .Range("B6").Value
strPath = strPath & "_" & .Range("X1").Value
strPath = strPath & "-JS-1.xlsm"
End With
Application.Dialogs(xlDialogSaveAs).Show strPath 'load file name with this argument
ActiveWorkbook.SaveAs FileFormat:=xlOpenXMLWorkbookMacroEnabled
End Sub
The main issue remaining was that opening from a template didn't automatically save as .xlsm. Apparently Application.Dialogs doesn't support file filters, so the problem is better solved with GetSaveasFileName.
Full code as follows:
Sub SaveAsString()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "N:\PROJECTS\"
strPath = strFolderPath & _
Sheet1.Range("B2").Value & "_" & _
Sheet1.Range("B6").Value & "_" & _
Sheet1.Range("X1").Value & "-JS-1" & ".xlsm"
fileSaveName = Application.GetSaveAsFilename(strPath _
, fileFilter:="Excel Files (*.xlsm), *.xlsm")
End Sub
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.
I have
error 53 'file not found'
Here is the most streamlined version of the script:
Sub Test()
Dim NJ As String, path As String, Oud As String, Archief As String, Nieuw As String
path = "C:\Test" & "\"
Oud = path & "A"
Archief = path & ("Archive") & "\" & "A"
Nieuw = path & "B"
Application.Workbooks.Add
ActiveWorkbook.SaveAs Oud
ActiveWorkbook.SaveAs Archief
ActiveWorkbook.SaveAs Nieuw
Kill Oud
End Sub
I tried to bypass the possibility of a too-long pathname by limiting it to its bare essentials.
I created a new file, which I gave a variable name to make sure no mistakes were made in the pathname.
I spoke with IT to make sure I have proper permissions to change, edit and delete files.
The script does not make a lot of sense, (why not just create Archief and Nieuw?), but I am trying to understand the error that occurs in another script in which I try to archive some files (say, "name 2017") in an archive folder, rename them for the new year in the original file (e.g. "name 2018") and then kill the original 2017 files to clean up the mess.
It does not make sense that the file I just created cannot be found.
Please do the below changes:
1) add these lines to your Code:
Dim filename As String
filename = "test.xls" 'You can select any name and any excel file format
2) Replace these lines:
Application.Workbooks.Add
ActiveWorkbook.SaveAs Oud
ActiveWorkbook.SaveAs Archief
ActiveWorkbook.SaveAs Nieuw
Kill Oud
With these:
ActiveWorkbook.SaveAs Oud & "\" & filename
ActiveWorkbook.SaveAs Archief & "\" & filename
ActiveWorkbook.SaveAs Nieuw & "\" & filename
Kill Oud & "\" & filename
I'm working with Excel 2016, I have created a Template with a main Sheet(G-Card) and the following 3 sheets get the information from the first sheet.
I have a Macro that allows me to save all 4 sheets into PDF creating a Folder in a specific location and saving it under that folder using cell values. I have also manage to save the workbook as a copy under the same filename in the same folder but it says that it is not compatible or extension error.
The only extension that seems to work is .xlm. I need to be able to save the template as a PDF and as an Excel file in the same folder including the macro in the 2016 version. Help please.. here is my code:
Sub NewFolder_SaveasPDF_CLICK()
Dim strFilename As String
Dim FldrName As String
On Error Resume Next
Set rngRANGE = Worksheets("G-Card").Range("U3")
FldrName = Worksheets("G-Card").Range("O4").Value
strFilename = rngRANGE.Value & " "
MkDir "Q:\Green Cards & Acknowledgement\Green Cards & Acknowledgement\2017 Orders\" & FldrName
Sheets(Array("G-Card", "P-AKG", "W-AKG", "Y-AKG")).Select Sheets("G-Card").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
"Q:\Green Cards & Acknowledgement\Green Cards & Acknowledgement\2017 Orders\" & FldrName & "\" & strFilename & Worksheets("G-Card").Range("O4").Value & ".pdf" _
, QUALITY:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True _
Dim ExcelWork As String
ExcelWork = strFilename & FldrName
ActiveWorkbook.SaveAs FileName:="Q:\Green Cards & Acknowledgement\Green Cards & Acknowledgement\2017 Orders\" & FldrName & "\" & ExcelWork & ".xlm", _
FileFormat:=xlNormal, Password:="", _
WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
End Sub
I am reading a list of files and come accross updated versions along the way. In my loop I am checking if the file already exists and trying to remove it, so that I can create the newer version again:
objFs = CreateObject("Scripting.FileSystemObject")
If (objFs.FileExists(location & "\" & fileName & ".xml")) Then
System.IO.File.Delete(location & "\" & fileName & ".xml")
End If
objTextStream = objFs.CreateTextFile(location & "\" & fileName & ".xml", True)
objTextStream.Write(System.Text.Encoding.UTF8.GetString(recordXml))
Ideally I would rather just open the file if it already exists and overwrite the contents, but so far my attempts have been in vein.
location is a user defined path, e.g. c://
recordXML is a retrieved value from the database
The main error I keep getting is
Additional information: Argument 'Prompt' cannot be converted to type 'String'.
Which seems to mean that the file is either not there to delete, or it is already there when I am trying to create it. The delete may not be working as it should, it may be that the file is not deleted in time to recreate it?..
That's my thoughts anyway.
Found this code at http://www.mrexcel.com/forum/excel-questions/325574-visual-basic-applications-check-if-folder-file-exists-create-them-if-not.html for creating a new file (unless one already exists) and then opening it (existing or new). Once you open, you can just do a Sheets(
NAMEOFSHEET").Cells.Clearto clear the cells and then paste your data.
Sub btncontinue_Click()
Dim myFile As String, myFolder As String
myFolder = "C:\TimeCards"
myFile = myFolder & "\timecards.xls"
If Not IsFolderExixts(myFolder) Then
CreateObject("Scripting.FileSystemObject").CreateFolder myFolder
End If
If Not IsFileExists(myFile) Then
MsgBox "No such file in the folder"
Exit Sub
End If
Set wb = Workbooks.Open(myFile)
' Your code here
End Sub
Function IsFolderExists(txt As String) As Boolean
IsFolderExists = _
Createobject("Scripting.FileSystemObject").FolderExists(txt)
End Function
Function IsFileExists(txt As String) As Boolean
IsFileExists = _
CreateObject("Scripting.FilesystemObject").FileExists(txt)
End Function
You could try this, it should work in VB, VBA and VBScript.
objFs = CreateObject("Scripting.FileSystemObject")
If objFs.FileExists(location & "\" & fileName & ".xml") Then Kill(location & "\" & fileName & ".xml")
Open location & "\" & fileName & ".xml" For Output As #1
Print #1, recordXml
Close #1
Try to use FSO to delete the file. Also the objTextStream needs to be set because it is object.
Sub AnySub()
Dim objFs As FileSystemObject
Set objFs = CreateObject("Scripting.FileSystemObject")
If (objFs.FileExists(Location & "\" & Filename & ".xml")) Then
objFs.DeleteFile Location & "\" & Filename & ".xml"
End If
Set objTextStream = objFs.CreateTextFile(Location & "\" & Filename & ".xml", True)
objTextStream.Write recordXml
End Sub
I m not sure the .write method work with UTF8.
I m using this function:
Sub File_WriteToUTF8(File_Path As String, s_Content As String)
On Error GoTo ende
Dim LineStream As Object
Set LineStream = CreateObject("ADODB.Stream")
With LineStream
.Type = 2
.Mode = 3
.Charset = "utf-8"
.Open
.WriteTEXT s_Content
.SaveToFile File_Path, 2
ende:
.Close
End With
End Sub
So instead of
objTextStream.Write recordXml
it would be
File_WriteToUTF8 Location & "\" & Filename & ".xml", recordXml