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
Related
I am currently trying to put a macro together to sort files into folders based on a filename. I am locked into using VBA due to the system we are on.
For example sorting just the excel documents from below present in C:\ :
123DE.xls
124DE.xls
125DE.xls
124.doc
123.csv
into the following folder paths:
C:\Data\123\Data Extract
C:\Data\124\Data Extract
C:\Data\125\Data Extract
The folders are already created, and as in the example are named after the first x characters of the file. Batches of 5000+ files will need to be sorted into over 5000 folders so im trying to avoid coding for each filename
I am pretty new to VBA, so any guidance would be much appreciated. So far I have managed to move all the excel files into a single folder, but am unsure how to progress.
Sub MoveFile()
Dim strFolderA As String
Dim strFolderB As String
Dim strFile as String
strFolderA = "\\vs2-alpfc\omgusers7\58129\G Test\"
strFolderb = "\\vs2-alpfc\omgusers7\58129\G Test\1a\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) >0
Name StrFolderA & strFile As strFolderB & strFile
strFile = Dir
Loop
End Sub
Greg
EDIT
Sub MoveFile()
Dim strFolderA As String
Dim strFile As String
Dim AccNo As String
strFolderA = "\\vs2-alpfc7\omgUSERS7\58129\G Test\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) > 0
AccNo = Left(strFile, 2)
Name strFolderA & strFile As strFolderA & "\" & AccNo & "\Data Extract\" & strFile
strFile = Dir
Loop
End Sub
Thanks folks, are a few more bits and pieces i want to add, but functionality is there!
Sub DivideFiles()
Const SourceDir = "C:\" 'where your files are
Const topdir = "\\vs2-alpfc\omgusers7\58129\G Test\"
Dim s As String
Dim x As String
s = Dir(SourceDir & "\*.xls?")
Do
x = Left(s, 3) 'I assume we're splitting by first three chars
Name SourceDir & s As topdir & s & "\" & s
Loop Until s = ""
End Sub
If I understand you correctly, the problem is deriving the new fullpathname from the file name to use as the newpathname argument of the Name function.
If all of your files end with DE.XLS* you can do something like:
NewPathName = C:\Data\ & Split(strFile, "DE")(0) & "\Data Extract\" & strFile
You could use Filesystem object (tools > references > microsoft scripting runtime
This does a copy first then delete. You can comment out delete line and check copy is safely performed.
If on Mac replace "\" with Application.PathSeparator.
Based on assumption, as you stated, that folders already exist.
Option Explicit
Sub FileAway()
Dim fileNames As Collection
Set fileNames = New Collection
With fileNames
.Add "123DE.xls"
.Add "124DE.xls"
.Add "125DE.xls"
.Add "124.doc"
.Add "123.csv"
End With
Dim fso As FileSystemObject 'tools > references > scripting runtime
Set fso = New FileSystemObject
Dim i As Long
Dim sourcePath As String
sourcePath = "C:\Users\User\Desktop" 'where files currently are
For i = 1 To fileNames.Count
If Not fso.FileExists("C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\" & fileNames(i)) Then
fso.CopyFile (sourcePath & "\" & fileNames(i)), _
"C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\", True
fso.DeleteFile (sourcePath & "\" & fileNames(i))
End If
Next i
End Sub
How can I save the excel file using vba code so that the Username and Date are attached in a macro?
Here is the code that I worked on to try to make it work:
ActiveWorkbook.SaveAs FileName:=(Environ$("Username")) & "_" & Date & "_BKMtracker.xlsx", FileFormat:=xlOpenXMLWorkbook
Try this:-
ActiveWorkbook.SaveAs FileName:=(Environ$("Username")) & "_" & Date & "_BKMtracker.xlsx", FileFormat:=xlOpenXMLWorkbook
With credit to #MatthewD
Sub SaveDocument()
Dim username As String
Dim nowFormated As String
Dim path As String
Dim filename As String
Dim extention As String
username = Environ("Username") & "_" 'gets the username
nowFormated = CStr(Format(now, "yymmdd")) 'or every format you like
path = "D:\" 'Wherever you want to save the file
filename = "_BKMtracker" 'or what you want
extention = ".xlsm" 'for example (with macros, else you have to change the FileFormat too)
ActiveWorkbook.SaveAs filename:=path & username & nowFormated & filname & extention, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub
I prepared a VBA Project in Microsoft Excel that has many userforms and macros. I want to export all of the files, but it appears you can only do this one by one, which would take me a very long time.
Is there any way to export the whole project? Thanks!
Here is some VBA code that I use to export VBA code:
'Requires Microsoft Visual Basic for Applications Extensibility
Private Function exportvba(Path As String)
Dim objVbComp As VBComponent
Dim strPath As String
Dim varItem As Variant
Dim fso As New FileSystemObject
Dim filename As String
filename = fso.GetFileName(Path)
On Error Resume Next
MkDir ("C:\Create\directory\for\VBA\Code\" & filename & "\")
On Error GoTo 0
'Change the path to suit the users needs
strPath = "C:\Give\directory\to\save\Code\in\" & filename & "\"
For Each varItem In ActiveWorkbook.VBProject.VBComponents
Set objVbComp = varItem
Select Case objVbComp.Type
Case vbext_ct_StdModule
objVbComp.Export strPath & "\" & objVbComp.name & ".bas"
Case vbext_ct_Document, vbext_ct_ClassModule
' ThisDocument and class modules
objVbComp.Export strPath & "\" & objVbComp.name & ".cls"
Case vbext_ct_MSForm
objVbComp.Export strPath & "\" & objVbComp.name & ".frm"
Case Else
objVbComp.Export strPath & "\" & objVbComp.name
End Select
Next varItem
End Function
The Path variable being passed in is the path to the file you want to export code from. If you have more than one file, just use this function in a loop.
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
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