Edit Macro to create folder on desktop for any user - excel

I have a spreadsheet with a save button on every sheet. The buttons currently save the sheets onto any user's desktop as a PDF file. I was asked if I could possibly make the button create a new folder titled "BSInHouseAssets" on the desktop when doing this. I am guessing that we would utilize MKdir at some point...but I need help.
Here is the current portion of the macro that saves the file.
Function SpecialFolderPath() As String
Dim objWSHShell As Object
Dim strSpecialFolderPath
'On Error GoTo ErrorHandler
' Create a shell object
Set objWSHShell = CreateObject("WScript.Shell")
' Find out the path to the passed special folder,
' just change the "Desktop" for one of the other options
SpecialFolderPath = objWSHShell.SpecialFolders("desktop")
' Clean up
Set objWSHShell = Nothing
Exit Function
ErrorHandler:
MsgBox "Error finding " & strSpecialFolder, vbCritical + vbOKOnly, "Error"
End Function

mkdir CreateObject("wscript.shell").specialfolders("desktop") & "\MyFolder"
should do the trick

strPath = "C:\Users\" & Environ("UserName") & "\Desktop\"
strFolderName = "test1"
strFullPath = strPath & strFolderName & "\"
If Dir(strPath & strFolderName, vbDirectory) = "" Then
MkDir strFullPath
End If
ActiveWorkbook.SaveAs Filename:=strFullPath & "workbookname1", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled

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

VBA to create folder from data validation list and allow user to select folder

I am encountering three problems with my code.
When users select a save folder it always saves in the folder above. For example, if the address is "Dept\Financial Analysis Team - General\Mail Out", it will always save to the Financial Analysis Team - General folder even though the Mail Out is the folder I have clicked.
I keep getting prompts to save with each time it loops. My macro loops through a data validation list, creates a folder (if none) and saves the specified PDF into their respective folders. The user is be able to select any folder they want in the selected Drive I have chosen.
If I do not select a folder (i.e. cancel), the macro runs on its own and actually creates the folder and PDF.
Function selectfolder()
user_name = Environ("username")
Dim flder As FileDialog
Dim foldername As String
Set flder = Application.FileDialog(msoFileDialogFolderPicker) 'standard wording
'Prompt for folder creation
With flder
.Title = "Select the folder to save"
.InitialFileName = "C:\Users\" & user_name & "\Dept\"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode 'i.e. if OK is not pressed
foldername = .SelectedItems(1)
End With
NextCode:
GetFolder = foldername
Set flder = Nothing
End Function
Sub SaveActiveSheetAsPDF()
'Creating a message box to ask user
If MsgBox("This will print to PDFs. Continue?", vbYesNo + vbQuestion + vbDefaultButton2, "Printing to PDFs") = vbNo Then Exit Sub
Dim inputrange As Range
Dim cell As Range
Dim network, Address, Folder, Title As String
'Determine (set) where validation comes from - create a reference point
Set inputrange = Evaluate(Range("G2").Validation.Formula1)
For Each cell In inputrange
Range("G2").Value = cell.Value
'Defining the Network Folder variables
network = Range("C6").Value
Address = selectfolder
Folder = Address & network
Title = "MonthlyReport (" & Format(Range("C8"), "mmmm") & ") - " & ActiveSheet.Range("B2").Value & " (" & ActiveSheet.Range("G2").Value & ")"
'Creating the folder based on Network - No existing folder
If Dir(Folder, vbDirectory) = "" Then
'Create a folder
MkDir Folder
'Save Active Sheet as PDF and to Network file
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Folder & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
'Creating Only the PDF based on Network - there is an existing folder
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Folder & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
End If
Next cell
'Create a message box at end of task to inform user it is complete
MsgBox "Generation of PDF Reports and Folders Completed", vbInformation, "Complete"
End Sub
I suggest you break in your code at different parts to see what the variables are. (To add a breakpoint, click in gray area along left to add a red circle.)
Folder = Address & network
Your "Address" variable likely doesn't end in a slash, so I'm guessing you'll need something like: Address & "\" & network
If you break on the line that creates the pdf, in the debug window you can type
?Folder & "\" & Title & ".pdf"
which will likely show why your files are not being saved in the location you are intending. You could also create a variable saveAs to store the full path, making it easier to see the value.
You should move the code to ask user for directory toward the top, outside of your for loop. I assume you only need to ask for a directory once.
If the user doesn't select a folder, you want to exit, but you don't have code to handle this. Something like below should work:
address = SelectFolder
If address = "" Then
MsgBox "Canceled."
Exit Sub
End If
This is the correct code revised :)
Option Explicit
Function selectfolder()
Dim user_name As String
user_name = Environ("username")
'Prompt for folder creation
With Application.FileDialog(msoFileDialogFolderPicker) 'standard wording
.Title = "Select the folder to save"
.InitialFileName = "C:\Users\" & user_name & "\Department\" 'base directory to open
.AllowMultiSelect = False
If .Show <> -1 Then Exit Function 'if user does not press OK, end the function'
selectfolder = .SelectedItems(1)
End With
End Function
Sub SaveActiveSheetAsPDF()
'Create a message box to ask user before proceeding
If MsgBox("This will print to PDFs. Continue?", vbYesNo + vbQuestion + vbDefaultButton2, "Printing to PDFs") = vbNo Then Exit Sub
'Defining the Type of Variables
Dim inputrange As Range
Dim cell As Range
Dim network, Address, Fldr, Title As String
'If user does not choose a folder
Address = selectfolder
If Address = "" Then
Exit Sub
End If
'Determine (set) where validation comes from - create a reference point
Set inputrange = Evaluate(Range("G2").Validation.Formula1)
For Each cell In inputrange
Range("G2").Value = cell.Value
'Defining the Company Network Folder variables
network = Range("C6").Value
Fldr = Address & "\" & network
Title = "MonthlyReport (" & Format(Range("C8"), "mmmm") & ") - " & ActiveSheet.Range("B2").Value & " (" & ActiveSheet.Range("G2").Value & ")"
'Creating the folder based on Company Network - No existing folder
If Dir(Fldr, vbDirectory) = "" Then
'Create a folder
MkDir Fldr
'Save Active Sheet as PDF and to Company Network file
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fldr & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
'Creating Only the PDF based on Company Network - there is an existing folder
Else
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Fldr & "\" & Title & ".pdf", _
Quality:=xlQualityStandard, _
IgnorePrintAreas:=False
End If
Next cell
'Create a message box at end of task to inform user it is complete
MsgBox "Generation of PDF Reports and Folders Completed", vbInformation, "Complete"
End Sub

how to open xlsm file from specific subfolder using VBA?

I am working on macro that takes the path from clipboard, goes through each folder and subfolder in this path, opens xlsm file in finance subfolder and deletes KPI sheet. Below you can find the folder structure in my path:
P:\main folder\project folder\finance subfolder\
P:\main folder\project folder\brief subfolder\
P:\main folder\project folder\production subfolder\
P:\main folder\project folder\delivery subfolder\
P:\main folder\project folder\feedback subfolder\
Basically, I copy "P:\main folder\" and my macro goes through all project folders and all subfolders. I want to optimise this process and write a code that goes through all project folders in main folder but then goes only to finance subfolder and looks for xlsm files. I've tried to use the code that was posted here but it works only if I put "P:\main folder\project folder\" path not if I put "P:\main folder\" path.
As far as I see the reason is that my macro is looking for finance subfolder not in project folder but in main folder but this is only my guess. Below you can find the code:
Sub test_macro()
Dim oLibrary As Object
Dim srcFolder As Object
Dim folderName As String
Dim clipboard As MSForms.DataObject
Dim CopiedText As String
Set clipboard = New MSForms.DataObject
clipboard.GetFromClipboard
CopiedText = clipboard.GetText
folderName = CopiedText
If StrPtr(folderName) = 0 Then
Exit Sub
End If
Set oLibrary = CreateObject("Scripting.FileSystemObject")
Merge_Rows oLibrary.GetFolder(folderName)
End Sub
Sub Merge_Rows(srcFolder As Object)
Dim srcSubFolder As Object
Dim srcFile As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each srcSubFolder In srcFolder.SubFolders
If Split(srcSubFolder, "\")(UBound(Split(srcSubFolder, "\"))) = "1_FINANCE" Then '<-- my guess is that here is the problem but not sure how to fix it
Merge_Rows srcSubFolder
End If
Next
For Each srcFile In srcFolder.Files
If LCase(srcFile.Name) Like "*.xlsm" Then
Set wbkSource = Workbooks.Open(srcFile)
On Error Resume Next
Application.DisplayAlerts = False
wbkSource.Sheets("KPI").Delete
Application.DisplayAlerts = True
wbkSource.Close SaveChanges:=True
End If
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
How can I change a code so it goes through each project folder but then goes only to finance subfolder and omits others?
Here is my idea, but it is done for 2 level subfolder (if I understood the task properly):
Sub Merge_Rows()
Dim srcFolder As Object
Dim srcSubFolder As Object
Dim srcSubSubFolder As Object
Dim srcFile As Object
Dim oLibrary As Object
' This is my testing vars
Dim FolderName As String
FolderName = "P:\"
'''''''''
' will need it as I'm not passing the folder to sub
Set oLibrary = CreateObject("Scripting.FileSystemObject")
Set srcFolder = oLibrary.getfolder(FolderName)
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' added for testing purposes
Dim fileCounter As Long
Debug.Print "-----------------" & "Source folder: " & FolderName & "--------------------------------"
Debug.Print Chr(10)
For Each srcSubFolder In srcFolder.Subfolders ' going to subfolders
' print the level 1 subfolder name, which should be a project folder
For Each srcSubSubFolder In srcSubFolder.Subfolders ' going to sub-subfolder
' print the level 2 subfolder name, which should be a project folder subfolder
Debug.Print "----------- Current SubFolder is: " & FolderName & srcSubFolder.Name & "-----------------"
If UCase(srcSubSubFolder.Name) Like "*FINANCE*" Then '<--!! put proper pattern
' go through it at once
For Each srcFile In srcSubSubFolder.Files
Debug.Print "----------------- Current SubSubFolder is: " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name & "---------------------"
If LCase(srcFile.Name) Like "*.xlsm" Then
Debug.Print srcFile.Name
fileCounter = fileCounter + 1
' Your code here
End If
Next
End If
If Not fileCounter = 0 Then
Debug.Print "There were " & fileCounter & " .xlsm files in " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name
fileCounter = 0
Else
Debug.Print "The search of .xlsm files in " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name & " was not performed"
End If
Debug.Print "-----------------" & "End of current SubSubFolder: " & FolderName & srcSubFolder.Name & "\" & srcSubSubFolder.Name & "---------------------"
Next
Debug.Print "-----------------" & "End current SubFolder: " & FolderName & srcSubFolder.Name & "---------------------"
Debug.Print Chr(10) & Chr(10)
Next
Debug.Print "<-----------------" & "End Source Folder" & "--------------------->"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
And it looks like this
If it fits - you need to fix it for your solution, it's just a thoughts :)
Update per OPs comment
I've updated code with some more Debug.Print lines
Here the file tree that I've created for testing:
Each folder has a "Book3.xlsm" file in it.
Here is the result of the updated script:
Try to run at least one iteration of project folder and check the immediate window.

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

Copy tabs in to a new unopened file and send in email with text in body and subject - VBA - Macro

have a segment of code that attaches copy tabs from a document and pastes them into a new document. Then sends only the new document to the intended addressees.
Is there a way I can change the name of the file I'm intending to send? It just sends as Book1.
Additionally, I'd like to add text in the body and the subject header of the email too. How can I go about doing this?
Sub Sendtabonemail()
Dim wb As Workbook
Dim strbody As String
Set wb = Workbooks.Add
ThisWorkbook.Sheets("sheet6").Copy After:=wb.Sheets(1)
ThisWorkbook.Sheets("sheet3").Copy After:=wb.Sheets(1)
wb.Application.Dialogs(xlDialogSendMail).Show "" & "emailreceiver1#domain.com" & "; " & "emailreceiver2#domain.com"
End Sub
Sub dfjero()
Dim newWBname As String
newWBname = Sheets(1).Name & "_" & Month(Date) & "_" & Day(Date) & "_" & Year(Date)
Workbooks.Add
If Len(Dir("c:\newFile", vbDirectory)) = 0 Then ' create and delete temporary directory and file
MkDir "c:\newFile"
ActiveWorkbook.SaveAs Filename:="C:\newFile\" & newWBname & ".xls", FileFormat:=xlExcel8
' This is where you send the book via email
ActiveWorkbook.Close
On Error Resume Next
Kill "C:\newFile\" & newWBname & ".xls"
RmDir "C:\newFile\"
On Error GoTo 0
Else ' or add file to already created directory
ActiveWorkbook.SaveAs Filename:="C:\newFile\" & newWBname & ".xls", FileFormat:=xlExcel8
' or alternatively this is where you send the workbook via email
End If
End Sub
It's calling it Book1 because that's the default name for a new workbook until it's saved. To name it, just save the file to a temporary location (with a name of your choosing) before sending.
wb.SaveAs "C:\temporary folder location\filename_to_use.xlsx"

Resources