Open file folder to specific location through VBA [duplicate] - excel

Using 2010 Excel VBA - I'm just trying to open a folder through a sub. What am I doing wrong here?
VBA
Sub openFolder()
Dim preFolder As String, theFolder As String, fullPath as String
theFolder = Left(Range("T12").Value, 8)
preFolder = Left(Range("T12").Value, 5) & "xxx"
fullPath = "P:\Engineering\031 Electronic Job Folders\" & preFolder & "\" & theFolder
Shell(theFolder, "P:\Engineering\031 Electronic Job Folders\" & preFolder, vbNormalFocus)
End Sub

If you want to open a windows file explorer, you should call explorer.exe
Call Shell("explorer.exe" & " " & "P:\Engineering", vbNormalFocus)
Equivalent syxntax
Shell "explorer.exe" & " " & "P:\Engineering", vbNormalFocus

I use this to open a workbook and then copy that workbook's data to the template.
Private Sub CommandButton24_Click()
Set Template = ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "I:\Group - Finance" ' Yu can select any folder you want
.Filters.Clear
.Title = "Your Title"
If Not .Show Then
MsgBox "No file selected.": Exit Sub
End If
Workbooks.OpenText .SelectedItems(1)
'The below is to copy the file into a new sheet in the workbook and paste those values in sheet 1
Set myfile = ActiveWorkbook
ActiveWorkbook.Sheets(1).Copy after:=ThisWorkbook.Sheets(1)
myfile.Close
Template.Activate
ActiveSheet.Cells.Select
Selection.Copy
Sheets("Sheet1").Select
Cells.Select
ActiveSheet.Paste
End With

Related

Why is Workbook.Open() triggered twice on Workbook.SaveAs

I just need my users to use the automatically saved copy of my file on their desktop when the file is located on SharePoint.
It looks like the Workbook.Open is triggered on SaveAs, as it execute the same code twice. I want it to close the SharePoint file - and reopen the new file from users desktop, but it seams to respond with the same path.
I have tried this in ThisWorkbook code:
`
Private Sub Workbook_Open()
MsgBox ThisWorkbook.Path
If Left(ThisWorkbook.Path, 2) <> "C:" Then
MsgBox "This workbook will now be saved on you desktop. Please use it from your desktop location."
ThisWorkbook.SaveAs Filename:="C:\Users\" & Environ$("Username") & _
"\Desktop\" & ThisWorkbook.Name, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
ThisWorkbook.Close
End If
End Sub
`
When using SaveAs (correct me if I'm wrong) on ThisWorkbook, it'll get you straight in the newly created file, instead of making a copy of itself and saving it in the same path. That's at least how I understood it since the MsgBoxes weren't triggered so it wasn't like the Workbook_Open got triggered again.
My workaround to not have it continue the code on it as follows, however when their C is virtually on the sharepoint (as I figured out mine is), the "C:" check is automatically True since your path will be from the sharepoint onwards (I noticed this with the second commented MsgBox):
Private Sub Workbook_Open()
Dim cFileName As String, cFileExists As String
Dim wb As Workbook
' MsgBox ThisWorkbook.Path
' MsgBox Left(ThisWorkbook.Path, 2)
If Left(ThisWorkbook.Path, 2) <> "C:" Then 'put your full path of original file here
MsgBox "This workbook will now be saved on you desktop. Please use it from your desktop location."
cFileName = "C:\Users\" & Environ("Username") & "\Dekstop\" & ThisWorkbook.Name
cFileExists = Dir(cFileName)
If cFileExists = "" Then 'check if it exists already
Set wb = ActiveWorkbook
wb.SaveCopyAs cFileName
Else
MsgBox "This file already exists"
End If
ThisWorkbook.Close
End If
End Sub
This way you can't have it open after running the code however. What you can also try is:
https://stackoverflow.com/a/19846141/19353309
Edit:
Private Sub Workbook_Open()
Dim cFileName As String, cFileExists As String
Dim wb As Workbook
If InStr(1, ActiveWorkbook.Path, Environ("Username")) > 0 Then Exit Sub 'if it's not original file, exit sub immediately, just don't put this file in a path with your name in it :p
'I would have used "C:\Users\" & Environ("Username") but this did not work with my copy.Path being part of the sharepoint even when the file is saved on C:\
cFileName = "C:\Users\" & Environ("Username") & "\Desktop\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & " - " & Environ("Username") & ".xlsm" 'this way both files can be open (can't have two workbooks with the same name open)
Set wb = ActiveWorkbook
cFileExists = Dir(cFileName)
If cFileExists = "" Then 'copy does not exist yet
MsgBox "This workbook will now be saved on you desktop. Please use it from your desktop location."
wb.SaveCopyAs cFileName
Else 'copy exists
MsgBox ("File already exists, opening this version")
End If
Workbooks.Open Filename:=cFileName
wb.Close
End Sub

opening excel workbooks in vba

below is a file path i need the workbook to open however this file path changes so i have an input box that gives the file path and dimmed as location
Workbooks.Open ("C:\Users\AylingB\OneDrive - TGE\Desktop\coding test for calcs\C5663-TD37-CAL-1900-0005_A TANK DOME ROOF STRUCTURE.xlsm")
so i instead have this
A = Range("p1")
B = Range("p2")
C = Range("p3")
Dim location As String
location = "(" & """" & A & B & C & """" & ")"
Debug.Print location
Workbooks.Open location
p1-3 is the file path split in certain cells(this cannot change unfortunately)
this does not work however even tho it equals the exact same pathway (brackets and quotaton marks included)
is there any way of doing this without having to go to the vba code every time and changing it
i have tried concatenation to bring everything together.
ive also tried it with and without brackets
with and without speech marks
im just abit lost as when i do debug .print the code looks exactly the same but only works when its typed out fully
The GetFileName function will ask open the FileDialog and ask you to select the file - starting in the same folder as the file containing the code (ThisWorkbook).
Test shows how to use it - and store a reference to it in a variable.
GetFileName is the function you should copy to your project.
Sub Test()
Dim MyFilePath As String
MyFilePath = GetFileName 'Ask for the filename & path
Dim MyFile As Workbook
'Check that a file was selected, and it wasn't this file.
If MyFilePath <> "" And MyFilePath <> ThisWorkbook.FullName Then
Set MyFile = Workbooks.Open(MyFilePath) 'Open the file and set a reference to it.
'Rest of your code.
'Use "MyFile" whenever referencing the workbook.
Dim MySheet As Worksheet
Set MySheet = MyFile.Worksheets(1)
Dim LastRow As Long
LastRow = MySheet.Cells(Rows.Count, 1).End(xlUp).Row
MsgBox MyFile.Name & " contains " & MyFile.Worksheets.Count & " worksheets." & vbCr & _
"The last row in " & MySheet.Name & " column A is " & LastRow
End If
End Sub
Private Function GetFileName() As String
Dim FD As FileDialog
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.InitialFileName = ThisWorkbook.Path & Application.PathSeparator
.AllowMultiSelect = False
'Not needed unless want to limit to specific file types.
.Filters.Clear 'On it's own will set filter to "All Files", "*.*"
.Filters.Add "Excel Files", "*.xlsx, *.xlsm, *.xls"
.Filters.Add "Other Files", "*.csv, *.someotherextension"
.FilterIndex = 2 'Display "Other Files" as default.
If .Show = -1 Then
GetFileName = .SelectedItems(1)
End If
End With
Set FD = Nothing
End Function

How to Run PPTM macro from excel for Embedded PPTM file

I have an Excel file with a .PPTM embedded into a sheet (nothing else is on the sheet). I want to run a macro that is in the PPTM file.
The problem is the last line of code to run the macro. The cell in worksheet "PPTM" that has the embedded file has a formula of "=EMBED("Presentation","")"
Sub run_ppt_macro()
fName = ActiveWorkbook.Name
Path = ActiveWorkbook.Path
Worksheets("PPTM").OLEObjects("PPT_Temp_19").Verb 0
Dim PPTObj As Object
Set myPP = GetObject(, "PowerPoint.Application")
Set PPTObj = myPP.ActivePresentation
PPTObj.Run PPTObj.Name & "!Main", fName, Path
End Sub
Thanks Shyam, that was part of the problem. Because the file is opened through IE or Email, it opens in a very odd place that errors the macro. I solved the problem by saving both the data (XLSM) file and the template (PPTM) file to the temp directory, before creating the new report.
Sub auto_open()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fName = ActiveWorkbook.Name
tempath = IIf(Environ$("tmp") <> "", Environ$("tmp"), Environ$("temp")) 'finds the temporary evironment on the current machine
ActiveWorkbook.SaveAs Filename:=(tempath & "\" & fName)
MsgBox "Your report " & tempath & "\" & fName & " should be completed within 5 minutes." & Chr(10) & Chr(10) & "Please check your PowerPoint application at that time." & Chr(10) & Chr(10) & "Thank you.", vbInformation
Dim PPTObj As Object
Worksheets("PPTM").OLEObjects("PPT_Temp_19").Verb 3 'opens the embedded object
Set myPP = GetObject(, "PowerPoint.Application") 'get the PowerPoint object
Set PPTObj = myPP.ActivePresentation 'Get the presentation that was opened
tempath = IIf(Environ$("tmp") <> "", Environ$("tmp"), Environ$("temp")) 'finds the temporary evironment on the current machine
Template = tempath & "\template.pptm" 'creates path and name for temp file
PPTObj.SaveAs Filename:=(Template) 'saves temp file
myPP.Presentations.Open (Template) 'opens the saved file
Worksheets("PPTM").OLEObjects("PPT_Temp_19").Object.Close
myPP.Run Template & "!Main", fName, tempath 'runs the macro
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

How to save xlsm as xlsx?

I have a xslm file. I want to save the file as xlsx and email.
I am able to SaveCopyAs it as xls file. If I try to save it as xlsx, it does get saved but when I open it, it gives an error.
ActiveWorkbook.SaveCopyAs Filename:=ActiveWorkbook.Path & "\MyFileName - " & Format(Date, "mm-dd-yyyy") & ".xlsx"
Excel cannot open the file '...path\MyFileName.xlsx' because the file format or file extension is not valid. Verify that file has not been corrupted and that file extension matches the format of the file
SaveCopyAs does not change the file-type.
You simply cannot save a .xlsm as .xlsx via SaveCopyAs.
EDIT
a workaround is to save a copy which then is changed in type while the old copy will be deleted like:
Dim wb As Workbook, pstr As String
pstr = ActiveWorkbook.Path & "\MyFileName - " & Format(Date, "mm-dd-yyyy") & ".xlsm"
ActiveWorkbook.SaveCopyAs Filename:=y
Set wb = Workbooks.Open(pstr)
wb.SaveAs Left(pstr, Len(pstr) - 1) & "x", 52
wb.Close False
Kill pstr
Try this:
Sub SaveAsXLSX()
ThisWorkbook.Save 'Optional
Application.DisplayAlerts = False
ThisWorkbook.SaveAs ActiveWorkbook.Path & "\MyFileName - " & Format(Date, "mm-dd-yyyy"), 51 '51 = xlsx
Application.DisplayAlerts = True
ThisWorkbook.Close 'Optional
End Sub
All you need to do is SaveAs and change the file format to 51 (xlsx)
If you want to "Save a copy" - SaveAs does practically the same thing - the difference being your currently open file becomes the saved file, but you can simply reopen the old one if you wish and nothing changes.
What you actually want to do is SaveAs a different file type, so use SaveAs.
I This is more readable. TESTED.
Sub SaveXlsmAsXlsx()
Dim wb As Workbook, Filenamepath As String, Filenameext As String, Filenameonly As String, Filepathonly As String
Application.DisplayAlerts = False
Filenamepath = ActiveWorkbook.FullName
Filenameext = ActiveWorkbook.Name
Filenameonly = Replace(Filenameext, ".xlsm", "")
Filepathonly = Replace(Filenamepath, ".xlsm", "")
Set wb = Workbooks.Open(Filenamepath)
'51 = xlsx
wb.SaveAs Filename:=Filepathonly & "_" & Format(Date, "mm-dd-yyyy"), FileFormat:=51
wb.Close True
'Kill- Best not to kill anyone, you might be sorry
ThisWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
End Sub
This code add to any module:
Public Sub XLSMtoXLSX(FaylAdi As String)
Dim FullPath As String
Dim wb As Workbook
MsgBox "YOU WILL GET A WARNING AFTER COMPLETED, PLEASE WAIT"
ThisWorkbook.Save
On Error GoTo XETA
'You can change the name of the folder path below
FullPath = "C:\kohne sistem\Excel\VBA\Anbar\temp\" & FaylAdi & ".xlsm"
ThisWorkbook.SaveCopyAs FullPath
Application.DisplayAlerts = False
Set wb = Workbooks.Open(FullPath)
wb.SaveAs Left(FullPath, Len(FullPath) - 1) & "x", 51
wb.Close False
Kill FullPath
Application.DisplayAlerts = True
MsgBox "COMPLETED CORRECTLY"
Exit Sub
XETA: MsgBox "THERE WAS A FAULT SOMEWHERE"
End Sub
Then you can use it like this:
Private Sub CommandButton1_Click()
Call XLSMtoXLSX(Date)
End Sub

Excel Macro: why won't this save in the correct directory?

I have an Excel macro that is copying all of the information from a specific worksheet and copying it into a new workbook. The code is as follows:
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, "New Copy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
On Error GoTo ErrCatcher
Sheets("Input").Copy
On Error GoTo 0
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
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
NewName = InputBox("Please specify the name of your new workbook", "New Copy", "input")
Dim sPath As String
sPath = ThisWorkbook.Path
ActiveWorkbook.SaveCopyAs sPath & NewName + ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
However, it does not save the new Excel file in the correct directory. The original Excel file, the one that contains the macro, is in the following directory (on a Mac):
/Applications/WORDNET/PROJECTS
However, every time I run the macro, it saves the new Excel file in the WORDNET folder, instead of the PROJECTS folder.
How do I modify the code so that it saves in the correct place? And why does it not save in the same directory as the original Excel file?
sPath = ThisWorkbook.Path
sPath is the path without a seperator at the end (at least on Windows) so you have to add one in your script. In your case, the files will be saved to /Applications/WORDNET with the name "PROJECTS" & NewName
Unix:
ActiveWorkbook.SaveCopyAs sPath & "/" & NewName + ".xls"
Windows:
ActiveWorkbook.SaveCopyAs sPath & "\" & NewName + ".xls"

Resources