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
Related
I've written a VBA macro which resides in an Excel workbook. When run, it will open an existing Word document (which is stored in the same directory as the Excel workbook), copy some content from cells in the Excel workbook into the Word document, save the Word doc under a new name (in the same directory) and kill the original Word doc. This process works as expected on first run. But on a second run, I get a Run-time error 462. I'm sure it's due to my ignorance around creating and using application instances within VBA code (I've just begun learning). I'm using Microsoft 365 Apps for Enterprise.
Sub ExcelToWord()
Dim wordApp As Word.Application
Dim wDoc As Word.Document
Dim strFile As String
'Open Word file
strFile = ("G:\HOME\Word File.docx")
Set wordApp = CreateObject("word.Application")
Set wDoc = wordApp.Documents.Open("G:\HOME\Word File.docx")
wordApp.Visible = True
'Copy data from Excel to Word
wDoc.ContentControls(1).Range.Text = Sheets("Model").Cells(4, 2)
wDoc.ContentControls(2).Range.Text = Format(Date, "mm/dd/yyyy")
wDoc.ContentControls(3).Range.Text = Sheets("Model").Range("X4")
Word.Application.Activate
'Save Word Document with new name
ActiveDocument.SaveAs Filename:=ActiveDocument.Path & "\" & Format(Sheets("Model").Range("B14"), "YYYY") & " " & ThisWorkbook.Sheets("Model").Range("B4") & " " & Format(Date, "YYYY-mm-dd") & ".docx"
'Delete original Word document
Kill strFile
End Sub
I've researched this for hours and tried multiple solutions, including commenting out all of the Copy Data block to try and zero in on the error. But no luck. I hope I've posted this request properly. Thank you in advance for any help.
Is this what you are trying? I have commented the code but if you face any issues, simply ask. What you have is Early Binding. I have used Late Binding so that you do not need to add any references to the MS Word application.
Option Explicit
Private Const wdFormatXMLDocument As Integer = 12
Sub ExcelToWord()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
Dim FilePath As String
Dim NewFileName As String
'~~> This is the original word file. Change as applicable
FlName = "G:\HOME\Word File.docx"
'~~> Check if word file exists
If Dir(FlName) = "" Then
MsgBox "Word File Not Found"
Exit Sub
End If
'~~> Establish an Word application object if open
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
'~~> If not open then create a new word application instance
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(FlName)
With oWordDoc
'~~> File path
FilePath = .Path & "\"
'~~> New File name
NewFileName = FilePath & _
Format(ThisWorkbook.Sheets("Model").Range("B14").Value, "YYYY") & _
" " & _
ThisWorkbook.Sheets("Model").Range("B4").Value & _
" " & _
Format(Date, "YYYY-mm-dd") & ".docx"
'~~> Copy data from Excel to Word
.ContentControls(1).Range.Text = Sheets("Model").Cells(4, 2).Value2
.ContentControls(2).Range.Text = Format(Date, "mm/dd/yyyy")
.ContentControls(3).Range.Text = Sheets("Model").Range("X4").Value2
'~~> Save the word document
.SaveAs Filename:=NewFileName, FileFormat:=wdFormatXMLDocument
DoEvents
End With
'~~> Delete original Word document
Kill FlName
End Sub
So i have a VBA script that takes user input via userform then creates an output workbook to contain the data and saves it as a .csv. The issue im having is when i want to create the folder that the files will be saved into the directory is not the same for each workstation because my company uses Microsoft One Drive which changes the file path for the desktop. I have gotten this to work on my machine but every time i send my form to a user for testing they receive a runtime error and the application cannot create the folder on the desktop. on one occasion the folder was saved in "My Documents" when that is nowhere in my code. Hope you can help.
i have changed my code several times using if statements to verify the file path but i still see the same issue
User = Environ("Username") 'set the current users username to the User variable
WBpath = "C:\Users\" & User & "\OneDrive - CompanyName\Desktop" 'windows directory where the file will go
WBpath2 = "C:\Users\" & User & "\Desktop" 'windows directory where the file will go
WBName = "BulkUpload" & UserForm1.TextBox5.value & ".csv" 'the name of the file
WBFile = WBpath & "\BulkUploadFiles\" & WBName 'full file path we will be saving the file in
WBFile2 = WBpath2 & "\BulkUploadFiles\" & WBName 'full file path we will be saving the file in
For Each wb In Workbooks 'loop through each open excel workbook and perform the below action
If wb.Name = WBName Then 'perform the below action only if the currently selected workbook has the same name as the output workbook
Workbooks(WBName).Close 'close the selected excel workbook
End If 'done checking if the file is already open
Next 'go to the next open excel workbook
'make the directory to save the bulkupload file to. create it if it doesnt already exist.
If Dir(WBpath, vbDirectory) <> "" Then 'check is the folder already exists
ChDir WBpath 'change the directory to WBPath
If Dir(WBpath & "\BulkUploadFiles\", vbDirectory) = "" Then
MkDir "BulkUploadFiles" 'create the output folder
End If
Set NewBook = Workbooks.Add 'create the output workbook
With NewBook 'set the properties for the output workbook
.Title = WBName 'add the workbook title
.Subject = WBName 'add the workbook subject
.SaveAs filename:=WBFile, FileFormat:=xlCSV, local:=True 'save the output workbook to the assigned directory as a CSV file
End With 'done setting file properties
End If
If Dir(WBpath2, vbDirectory) <> "" Then 'check is the folder already exists
ChDir WBpath2 'change the directory to WBPath2
If Dir(WBpath2 & "\BulkUploadFiles\", vbDirectory) = "" Then
MkDir "BulkUploadFiles" 'create the output folder
End If
Set NewBook = Workbooks.Add 'create the output workbook
With NewBook 'set the properties for the output workbook
.Title = WBName 'add the workbook title
.Subject = WBName 'add the workbook subject
.SaveAs filename:=WBFile2, FileFormat:=xlCSV, local:=True 'save the output workbook to the assigned directory as a CSV file
End With 'done setting file properties
End If
Workbooks(WBName).Sheets("BulkUpload" & UserForm1.TextBox5.value).Name = "Sheet1" 'rename the first sheet in the output workbook back to Sheet1 so we can reference it correctly later
Workbooks(WBName).Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Sheet3" 'add a new sheet to the output workbook
Workbooks(WBName).Sheets("Sheet3").Visible = xlSheetHidden 'hide the new sheet we just made (Sheet3)
on my workstation (with one drive installed) this works fine but on other users pcs i receive an error when attempting to create the folder and fil
Instead of this:
ChDir WBpath 'change the directory to WBPath
If Dir(WBpath & "\BulkUploadFiles\", vbDirectory) = "" Then
MkDir "BulkUploadFiles" 'create the output folder
End If
You can skip the ChDir and just use something like this:
fPath = WBpath & "\BulkUploadFiles"
If Dir(fPath, vbDirectory) = "" Then
MkDir fPath
End If
ChDir does not set the working folder if the user's current working folder is on a different drive
EDIT: this worked for me but I'm not sure what you want to do when adding multiple sheets to a CSV-format file, since a CSV can have only one "sheet"
Dim deskTop, wbName As String, folderName As String, newBook As Workbook
Dim txtVal As String
txtVal = UserForm1.TextBox5.Value
deskTop = CreateObject("Wscript.Shell").specialfolders("Desktop")
wbName = "BulkUpload" & txtVal & ".csv" 'the name of the file
'close the workbook if it's open
On Error Resume Next 'ignore error if the file is not open
Workbooks(wbName).Close
On Error GoTo 0 'stop ignoring errors
folderName = deskTop & "\BulkUploadFiles\"
If Len(Dir(folderName, vbDirectory)) = 0 Then MkDir folderName
Set newBook = Workbooks.Add 'create the output workbook
With newBook
.Title = wbName
.Subject = wbName
.SaveAs Filename:=folderName & wbName, FileFormat:=xlCSV, local:=True
.Sheets(1).Name = "Sheet1"
'??? a csv file can't have multiple sheets...
'.Sheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = "Sheet3"
'.Worksheets(.Worksheets.Count).Visible = xlSheetHidden
End With
Here is my updated code. I tried using if statements to validate the path but this is still failing on every workstation except mine.
Dim NewBook As Variant
Dim WBpath, WBpath2, WBName, WBFile, WBFile2, WBDir, WBDir2, Fpath, Fpath2 As String
Dim User As String
Dim WS As Worksheet
Dim wb As Workbook
User = Environ("Username") 'set the current users username to the User variable
WBpath = "C:\Users\" & User & "\OneDrive - CompanyName\Desktop" 'windows directory where the file will go
WBpath2 = "C:\Users\" & User & "\Desktop" 'windows directory where the file will go
WBName = "BulkUpload" & UserForm1.TextBox5.value & ".csv" 'the name of the file
WBFile = WBpath & "\BulkUploadFiles\" & WBName 'full file path we will be saving the file in
WBFile2 = WBpath2 & "\BulkUploadFiles\" & WBName 'full file path we will be saving the file in
For Each wb In Workbooks 'loop through each open excel workbook and perform the below action
If wb.Name = WBName Then 'perform the below action only if the currently selected workbook has the same name as the output workbook
Workbooks(WBName).Close 'close the selected excel workbook
End If 'done checking if the file is already open
Next 'go to the next open excel workbook
'make the directory to save the bulkupload file to. create it if it doesnt already exist.
Fpath = WBpath & "\BulkUploadFiles\"
If Dir(WBpath2, vbDirectory) <> "" Then
If Dir(Fpath, vbDirectory) = "" Then
MkDir Fpath
Set NewBook = Workbooks.Add 'create the output workbook
With NewBook 'set the properties for the output workbook
.Title = WBName 'add the workbook title
.Subject = WBName 'add the workbook subject
.SaveAs filename:=WBFile, FileFormat:=xlCSV, local:=True 'save the output workbook to the assigned directory as a CSV file
End With 'done setting file properties
End If
End If
Fpath2 = WBpath2 & "\BulkUploadFiles\"
If Dir(WBpath2, vbDirectory) <> "" Then
If Dir(Fpath2, vbDirectory) = "" Then
MkDir Fpath
Set NewBook = Workbooks.Add 'create the output workbook
With NewBook 'set the properties for the output workbook
.Title = WBName 'add the workbook title
.Subject = WBName 'add the workbook subject
.SaveAs filename:=WBFile2, FileFormat:=xlCSV, local:=True 'save the output workbook to the assigned directory as a CSV file
End With 'done setting file properties
End If
End If
Workbooks(WBName).Sheets("BulkUpload" & UserForm1.TextBox5.value).Name = "Sheet1" 'rename the first sheet in the output workbook back to Sheet1 so we can reference it correctly later
Workbooks(WBName).Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Sheet3" 'add a new sheet to the output workbook
Workbooks(WBName).Sheets("Sheet3").Visible = xlSheetHidden 'hide the new sheet we just made (Sheet3)
I have a macro that get data from a word file and writes it into an excel file and saves it to a specific location.
I want the user to be able to choose where to save the file.
This is my current code:
Sub createExcelFile()
Dim mPathSave As String
Dim xlsApp As Excel.Application
Dim xlsWB As Workbook
Set xlsApp = CreateObject("Excel.Application")
Set xlsWB = xlsApp.Workbooks.Add
'Want to make it dynamic'
mPathSave = "C:\temp"
callFunc = createExcel.createExcel(xlsApp, xlsWB)
'Save the excel file
xlsWB.SaveAs mPathSave & "\" & "teste" & ".xls", FileFormat:=56
xlsWB.Close
xlsApp.Quit
MsgBox "Novo arquivo salvo em: " & mPathSave & "\" & "teste" & ".xls", vbInformation
End Sub
I tried to use Application.FileDialog to open the dialog to choose the place, but I can't make it save a excel, it opens to save a word file.
Here is a simple example
Sub createExcelFile()
Dim mPathSave As String
Dim xlsApp As Excel.Application
Dim xlsWB As Workbook
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
Set xlsWB = xlsApp.Workbooks.Add
'Want to make it dynamic'
Application.FileDialog(msoFileDialogFolderPicker).Show
mPathSave = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
'Save the excel file
xlsWB.SaveAs mPathSave & "\" & "teste" & ".xls", FileFormat:=56
xlsWB.Close
xlsApp.Quit
End Sub
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
I'm trying to run a macro that corrects a linked cell designation with checkboxes within a set of workbooks.
There are many (around 100) workbooks that need adjusting in one file.
As such I am looping through these files and running the reassignment, however, it only ever applies to the file in which I wrote the macro:
Sub CheckBoxesControl()
On Error Resume Next
Dim path As String
Dim file As String
Dim wkbk As Workbook
Dim i As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
path = "C:\file\path\"
file = Dir(path)
Do While Not file = ""
Workbooks.Open (path & file)
Set wkbk = ActiveWorkbook
For i = 1 To 400
ActiveWorkbook.Sheet4.CheckBoxes("Check Box " & i).LinkedCell = "ChkBoxOutput!AA" & i
ActiveWorkbook.Sheet21.CheckBoxes("Check Box " & i).LinkedCell = "ChkBoxOutput!AB" & i
Activekbook.Sheet22.CheckBoxes("Check Box " & i).LinkedCell = "ChkBoxOutput!AC" & i
Next i
wkbk.Save
wkbk.Close
file = Dir
Loop
End Sub
Can anyone tell me how to adjust it so that it is applied to each file?
The macro runs without errors (and indeed each file in the file does seem to be opened and closed).
Don't use ActiveWorkbook, it can confuse matters (same as using ActiveCell / Selection) - do it like this:
Do While Not file = ""
Set wkbk = Workbooks.Open (path & file)
For i = 1 To 400
wkbk.Sheet4.CheckBoxes("Check Box " & i).LinkedCell = "ChkBoxOutput!AA" & i
wkbk .Sheet21.CheckBoxes("Check Box " & i).LinkedCell = "ChkBoxOutput!AB" & i
wkbk .Sheet22.CheckBoxes("Check Box " & i).LinkedCell = "ChkBoxOutput!AC" & i
Next i
wkbk.Save
wkbk.Close
file = Dir
Loop