Hi I just embed this code into my vba macro, but how to change default directory when I use this macro.. for example when I click it is going to D:/myfolder
I found this code at google :
Sub Copy_ActiveSheet_2()
'Working in Excel 2000-2013
Dim fname As Variant
Dim NewWb As Workbook
Dim FileFormatValue As Long
'Check the Excel version
If Val(Application.Version) < 9 Then Exit Sub
If Val(Application.Version) < 12 Then
'Only choice in the "Save as type" dropdown is Excel files(xls)
'because the Excel version is 2000-2003
fname = Application.GetSaveAsFilename(InitialFileName:="", _
filefilter:="Excel Files (*.xls), *.xls", _
Title:="This example copies the ActiveSheet to a new workbook")
If fname <> False Then
'Copy the ActiveSheet to new workbook
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
'We use the 2000-2003 format xlWorkbookNormal here to save as xls
NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End If
Else
'Give the user the choice to save in 2000-2003 format or in one of the
'new formats. Use the "Save as type" dropdown to make a choice,Default =
'Excel Macro Enabled Workbook. You can add or remove formats to/from the list
fname = Application.GetSaveAsFilename(InitialFileName:="", filefilter:= _
" Excel Macro Free Workbook (*.xlsx), *.xlsx," & _
" Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
" Excel 2000-2003 Workbook (*.xls), *.xls," & _
" Excel Binary Workbook (*.xlsb), *.xlsb", _
FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook")
'Find the correct FileFormat that match the choice in the "Save as type" list
If fname <> False Then
Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
Case "xls": FileFormatValue = 56
Case "xlsx": FileFormatValue = 51
Case "xlsm": FileFormatValue = 52
Case "xlsb": FileFormatValue = 50
Case Else: FileFormatValue = 0
End Select
'Now we can create/Save the file with the xlFileFormat parameter
'value that match the file extension
If FileFormatValue = 0 Then
MsgBox "Sorry, unknown file extension"
Else
'Copies the ActiveSheet to new workbook
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
'Save the file in the format you choose in the "Save as type" dropdown
NewWb.SaveAs fname, FileFormat:= _
FileFormatValue, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End If
End If
End If
End Sub
Change this part of the code
fname = Application.GetSaveAsFilename(InitialFileName:=""
to include the default save path you would like
fname = Application.GetSaveAsFilename(InitialFileName:=""C:\My Documents\"
Make sure you leave the trailing backslash, otherwise a default file will be suggested with a filename equal to the the path you have provided eg.
fname = Application.GetSaveAsFilename(InitialFileName:=""C:\My Documents"
Will result in a dialog where the default file named "My Documents" is saved in the location "C:\"
Related
I have 2 different type of files. 1 is ".tsv" 2 is ".xlsx".
I want my macro (.xlsm) file to be in same folder where 2 different files (.tsv and .xlsx) are placed. I usually download them from some tools and normally they are placed in my default "Download" folder.
Problem 1: I want my macro file to read both format and copy paste data into single excel file. I am done with this problem. Code optimization is required.
Problem 2: I am currently assigning manual path to that folder and want macro to pick that folder path so that it can copy 2 extension files and proceed.
(Tried : ActiveWorkbook.Path, didn't work).
Dim FPath As String, filename As String, FileExt1 As String, FileExt2 As
String
Sub GetSheets()
FPath = "C:\Users\dinekuma\Desktop\Dinesh KT\Macro New UI\"
FileExt1 = "*.tsv"
FileExt2 = "*.xlsx"
'ActiveWorkbook.Path
'"C:\Users\dinekuma\Desktop\Dinesh KT\Macro New UI\"
filename = Dir(FPath & FileExt1)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While filename <> ""
Workbooks.Open filename:=FPath & filename, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = Split(filename, ".")(0)
Next sheet
Workbooks(filename).Close
filename = Dir()
Loop
filename = Dir(FPath & FileExt2)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While filename <> ""
Workbooks.Open filename:=FPath & filename, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
ActiveSheet.Name = Split(filename, ".")(0)
Next sheet
Workbooks(filename).Close
filename = Dir()
Loop
MsgBox ("Import Successful!")
End Sub
Help in code optimization and automatic path pick by active macro file.
I have a workbook that I format through macros I recorded. The macros currently rename the file and save it to a constant path, but I need it to rename the file and save it to a relative path so that other teammates can use it. Are there any suggestions?
This is the active file
Windows("Manual Reconciliation Template.xlsm").Activate
This is the constant path
ActiveWorkbook.SaveAs FileName:= _
"C:\Users\e6y550m\Documents\MANUAL RECS\Manual Reconciliation Template.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Current code:
Sub Name_And_Save_Report()
'
' TO NAME, DATE AND SAVE THE REPORT AFTER IT HAS BEEN WORKED.
'
Windows("Manual Reconciliation Template.xlsm").Activate
Dim thisWb As Workbook
Dim fname
fname = InputBox("Enter your name (example-John):")
Set thisWb = ActiveWorkbook
Workbooks.Add
ActiveWorkbook.SaveAs FileName:=thisWb.Path & "\" & fname & "_Manual Recon" & " " & Format(Date, "MM.DD.YY") & ".xlsx"
ActiveWorkbook.Close savechanges:=False
Windows("Manual Reconciliation Template.xlsm").Activate
ActiveWorkbook.Close savechanges:=False
End Sub
So, you'll paste a copy of the workbook containing the above code in each persons folder. When they open the workbook you want it to rename itself as:
<< person name >>_Manual Recon << mm.dd.yy >>.xlsx
I assume you want the original file left in there so they can open it and create a new xlsx for the following day, but not create a file if it already exists (in case they open the xlsm twice in one day).
Another point to consider - is their personal folder given their name?
E.g. G:\MMS Trade Payables\John
I noticed in your code you set a variable thisWb to equal the ActiveWorkbook.
You could just use ThisWorkbook which always refers to the workbook that the code is running in.
So with these assumptions, try this code:
Sub Name_And_Save_Report()
Dim fName As String
Dim sNewFile As String
'Get the folder name.
fName = GetParentFolder(ThisWorkbook.Path)
'Could also get the Windows user name.
'fName = Environ("username")
'Or could get the Excel user name.
'fname = application.username
'Or could just ask them.
'fname = InputBox("Enter your name (example-John):")
sNewFile = ThisWorkbook.Path & Application.PathSeparator & _
fName & "_Manual Recon " & Format(Date, "mm.dd.yy") & ".xlsx"
If Not FileExists(sNewFile) Then
'Turn off alerts otherwise you'll get
'"The following features cannot be saved in macro-free workbooks...."
'51 in the SaveAs means save in XLSX format.
Application.DisplayAlerts = False
ThisWorkbook.SaveAs sNewFile, 51
Application.DisplayAlerts = True
End If
End Sub
Public Function FileExists(ByVal FileName As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(FileName)
Set oFSO = Nothing
End Function
Public Function GetParentFolder(ByVal FilePath As String) As String
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
GetParentFolder = oFSO.GetFolder(FilePath).Name
Set oFSO = Nothing
End Function
I'll leave this here as my first answer:
Do you mean something like this?
Using the FileSystemObject to recursively get the parent folder name.
Sub Test()
MsgBox ThisWorkbook.Path & vbCr & RelativePath(ThisWorkbook.Path, 2)
'Will return "C:\Users\e6y550m" - step back 2 folders.
MsgBox RelativePath("C:\Users\e6y550m\Documents\MANUAL RECS\", 2)
'Your line of code:
'ActiveWorkbook.SaveAs FileName:=RelativePath(thisWb.Path, 2) & "\" & fname & "_Manual Recon" & " " & Format(Date, "MM.DD.YY") & ".xlsx"
End Sub
'FilePath - path to file, not including file name.
'GetParent - the number of folders in the path to go back to.
Public Function RelativePath(FilePath As String, Optional GetParent As Long) As String
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
'If rightmost character is "\" then we've reached the root: C:\
If GetParent = 0 Or Right(FilePath, 1) = Application.PathSeparator Then
RelativePath = oFSO.GetFolder(FilePath)
'If we've reached the root then remove the "\".
If Right(RelativePath, 1) = Application.PathSeparator Then
RelativePath = Left(RelativePath, Len(RelativePath) - 1)
End If
Else
'GetParent is greater than 0 so call the RelativePath function again with
'GetParent decreased by 1.
RelativePath = RelativePath(oFSO.GetParentFolderName(FilePath), GetParent - 1)
End If
Set oFSO = Nothing
End Function
I apologize if my question wasn't clear; I am a VBA novice at best.
'This is the current file that is already open,
Windows("Manual Reconciliation Template.xlsm").Activate
' I want to share this file with my teammates so they can use it. They all have different folders. I will place a copy of this workbook in each of their folders. When they use the copy that is in their personal folder, the macro needs to rename the workbook and save the renamed copy in their personal folder. The macro therefore needs code that will rename the workbook and save it in their folder without having a defined path. The shared drive path is G:\MMS Trade Payables. Within the MMS Trade Payables folder are the personal folders. I think the code just needs to activate the current workbook that is already open, rename it and save it in the current folder as an .xlsx instead of an .xlsm.
Current code:
Sub Name_And_Save_Report()
'
' TO NAME, DATE AND SAVE THE REPORT AFTER IT HAS BEEN WORKED.
'
Windows("Manual Reconciliation Template.xlsm").Activate
Dim thisWb As Workbook
Dim fname
' Will use the fname variable to add the associates name to the file name (ex:If the associate enters Mark into the inputbox, fname will = Mark).
fname = InputBox("Enter your name (example-John):")
' Makes thisWb = "Manual Reconciliation Template.xlsm".
Set thisWb = ActiveWorkbook
Workbooks.Add
' Saves the active workbook ("Manual Reconciliation Template.xlsm") to the path of thisWb and renames the workbook by adding the fname value and the current date (ex: if the associate entered Mark as the value of fname, "Manual Reconciliation Template.xlsm" becomes "Mark_Manual Recon 7.14.17.xlsx").
ActiveWorkbook.SaveAs FileName:=thisWb.Path & "\" & fname & "_Manual Recon" & " " & Format(Date, "MM.DD.YY") & ".xlsx"
' Closes the renamed workbook.
ActiveWorkbook.Close savechanges:=False
' Calls the original workbook and closes it.
Windows("Manual Reconciliation Template.xlsm").Activate
ActiveWorkbook.Close savechanges:=False
End Sub
Of course, this could be completely wrong since I am new to VBA.
Hello thanks for reading my question, I have a Workbook with hidden templates and most of them are used as Excel .xlsx spreadsheet however one of them requires a module to be inserted for it to work. I thought simple enough just add a param to my function that creates the workbook.
It doesn't seem to work because i get an error "Error Number 1004 This extension can not be used with the selected file type. Change the file extension in the file name text box or select a different file type blabla"
Public Function gWrkBook(template As String, Optional wbMacro As Boolean) As Workbook
Dim wbNew As Workbook
Dim wsTemplate As Worksheet, wsSummary As Worksheet
Set wsTemplate = ThisWorkbook.Worksheets(template) '===== Create new workbook and copy template
wsTemplate.Visible = True
'
Set wbNew = Workbooks.Add 'Create New file
wsTemplate.Copy Before:=wbNew.Sheets(1) 'Copy template to new workbook
'Rename sheet
On Error GoTo ErrSheetName
wbNew.Sheets(1).Name = "SUMMARY"
Set wsSummary = wbNew.Sheets("SUMMARY")
wsTemplate.Visible = False '===== Clean up
Call gRemoveUnwanted("sheets", wbNew) 'Mod7 '==== Get SaveAs filename and save file
If wbMacro = True Then
vFileName = Application.GetSaveAsFilename(Filname, "Excel Macro-Enabled workbook(*.xlsm), *.xlsm", Title:="SaveAs Workbook Macro-Enabled")
Else
vFileName = Application.GetSaveAsFilename(FileFilter:="Microsoft Excel Workbooks, *.xlsx", Title:="SaveAs Workbook")
End If
On Error GoTo ErrFileName
wbNew.SaveAs Filename:=vFileName
Set gWrkBook = wbNew 'must assign it this way?? not sure why R2
Exit Function
ErrSheetName:
NewSheetName = InputBox("Worksheet exists, try a different name." & vbCrLf & "Enter Sheet Name.")
Resume
ErrFileName:
MsgBox "Error Number " & _
Err.Number & vbCrLf & _
Error(Err) & vbCrLf & _
"Try Again!", _
vbExclamation + vbOKOnly, _
"ERROR!"
vFileName = Application.GetSaveAsFilename(FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", _
Title:="SaveAs Workbook")
Resume
End Function
Try:
wbNew.SaveAs(Filename:=vFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled)
For more information, please read documentation:
VBA SaveAs
VBA File Format XlFileFormat Enumeration.
I have working code that copies cells in a file and pastes into a newly created document that is generated with VBA code. I am looking to Save As this newly created document, which is currently is able to do. I created a csPath variable to try and specify a location for the document to Save As in, but it will only either save on my desktop or runs into an error. Any advice?
'Declaring variables for the Save As function
Dim fname As Variant ' Required for declaring the document name
Dim NewWb As Workbook ' Specifies the new workbook for the Save As function
Dim FileFormatValue As Long ' Allows programmer to declare what file formats that can be in the Save As function, currently only .xlsx
Dim csPath As String ' Allows program to set location for Save As function
'Begin the Save As function for easy operator reference of old batches
csPath = "\\346nafp1\shares$\Departments\Starch\Wetend\Transfer\old - dont touch\"
' Check the Excel version
If Val(Application.Version) < 9 Then Exit Sub
If Val(Application.Version) < 12 Then
' Only choice in the "Save as type" dropdown is Excel files(xls)
' if the Excel version is 2000-2003
fname = Application.GetSaveAsFilename(InitialFileName:="", _
Filefilter:="Excel Files (*.xls), *.xls", _
Title:="This example copies the ActiveSheet to a new workbook")
If fname <> False Then
' Copy the ActiveSheet to new workbook
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
' We use the 2000-2003 format xlWorkbookNormal here to save as xls
NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End If
Else
' Force to save as .xls for archiving in the History folder
' Files available there for use in the future for reference
' But disable macros to prevent changing or confusion when looking at archives
fname = Application.GetSaveAsFilename(InitialFileName:=Worksheets("Oxy1").Cells(4, 7) & " " & Worksheets("Oxy1").Cells(4, 11), _
Filefilter:= _
" Excel Macro Free Workbook (*.xls), *.xls,", _
FilterIndex:=2, Title:="Save and archive for new batch")
' Add the code to the Filefilter above if additional formats are needed
' Include " before the word Excel to add it in
' Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _
' Excel 2000-2003 Workbook (*.xls), *.xls," & _
' Excel Binary Workbook (*.xlsb), *.xlsb", _
' Find the correct FileFormat that match the choice in the "Save as type" list
If fname <> False Then
Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1)))
Case "xls": FileFormatValue = 56
Case "xlsx": FileFormatValue = 51
Case "xlsm": FileFormatValue = 52
Case "xlsb": FileFormatValue = 50
Case Else: FileFormatValue = 0
End Select
' Now we can create/Save the file with the xlFileFormat parameter
' value that match the file extension
If FileFormatValue = 0 Then
MsgBox "Sorry, unknown file extension"
Else
' Copies the ActiveSheet to new workbook
ActiveSheet.Copy
Set NewWb = ActiveWorkbook
'Save the file in the format you choose in the "Save as type" dropdown
NewWb.SaveAs fname, FileFormat:= _
FileFormatValue, CreateBackup:=False
NewWb.Close False
Set NewWb = Nothing
End If
End If
End If
Define it in your saveas with the filename:= argument.
NOTE: Not sure if it is going to like saving to a UNC\share.
NewWb.SaveAs filename:="C:\Temp\NewFilename.xls", FileFormat:=56, CreateBackup:=False
or with your variable
NewWb.SaveAs filename:=csPath & "\NewFilename.xls", FileFormat:=56, CreateBackup:=False
Also here in some infor on the fileformat arg. Not sure what your FileFormat:=-4143 is trying to do.
These are the main file formats in Excel 2007-2016, Note: In Excel for the Mac the values are +1
51 = xlOpenXMLWorkbook (without macro's in 2007-2013, xlsx)
52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2013, xlsm)
50 = xlExcel12 (Excel Binary Workbook in 2007-2013 with or
without macro's, xlsb)
56 = xlExcel8 (97-2003 format in Excel
2007-2013, xls)
I am using the following VBA to save specific sheets. I would like to save the sheets at HTML. I tried changing the . xls to .html but all I get is gobby gook (technical term) Any help would be appreciated.
Option Explicit
Sub TwoSheetsAndYourOut()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, separated by commas
On Error GoTo ErrCatcher
Sheets(Array("Copy Me", "Copy Me2")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
Use Ron de Bruin's RangetoHTML code. Call it from within your For Each ws... loop
I found the solution,
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.SaveAs Filename:="C:**locationtosave**.html", FileFormat:=xlHtml