I am trying to copy 1st slide from the powerpoint and insert it at the end but I am getting ActiveX can't create object on the line
ActivePresentation.Slides(1).Copy
This is my full code and I've added the reference to microsoft powerpoint library as well
Option Explicit
Dim myFile, Fileselected As String, Path As String, objPPT As Object
Dim activeSlide As PowerPoint.Slide
Sub Generate_PPTs()
Application.ScreenUpdating = False
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Template PPT File."
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
Fileselected = .SelectedItems(1)
End With
Path = Fileselected
Set objPPT = CreateObject("PowerPoint.Application")
Set objPPT = objPPT.Presentations.Open(Path)
Debug.Print objPPT.Name
ActivePresentation.Slides(1).Copy
ActivePresentation.Slides.Paste Index:=objPPT.Slides.Count + 1
Set activeSlide = objPPT.Slides(objPPT.Slides.Count)
Application.ScreenUpdating = True
Set objPPT = Nothing
End Sub
Try edited code below, I have ppApp As PowerPoint.Application and Dim ppPres As PowerPoint.Presentation :
Option Explicit
Dim myFile, Fileselected As String, Path As String, objPPT As Object
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim activeSlide As PowerPoint.Slide
Sub Generate_PPTs()
Application.ScreenUpdating = False
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.Title = "Choose Template PPT File."
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Sub
End If
Fileselected = .SelectedItems(1)
End With
Path = Fileselected
Dim i As Integer
Set ppApp = New PowerPoint.Application
i = 1
ppApp.Presentations.Open Filename:=Path ' 'PowerPointFile = "C:\Test.pptx"
Set ppPres = ppApp.Presentations.Item(i)
' for debug
Debug.Print ppPres.Name
ppPres.Slides(1).Copy
ppPres.Slides.Paste Index:=ppPres.Slides.Count + 1
Set activeSlide = ppPres.Slides(ppPres.Slides.Count)
Application.ScreenUpdating = True
Set ppPres = Nothing
Set ppApp = Nothing
End Sub
Related
I want to insert the Excel file at the seartain BOOkmark in the Word doc without opening Excel, automatically inserted when the Word doc opens.
1.I'm thinking to make a pop up window with a open file dialog bottom firstly. And my code is following:(but it only work in excel VBA doesn't work in word VBA how should I change the code so that I can do it in word??? )
Sub openfile()
Dim intChoice As Integer
Dim strPath As String
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
End If
End Sub
Then I made a copy and paste bottom the code is as follows:(It also only work when l code it in excel how to change to word vba?)
Sub CopyWorksheetsToWord()
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Add
For Each ws In ActiveWorkbook.Worksheets
ws.UsedRange.Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
Application.CutCopyMode = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not ws.Name = Worksheets(Worksheets.Count).Name Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
Next ws
Set ws = Nothing
Application.StatusBar = "Cleaning up..."
With wdApp.ActiveWindow
If .View.SplitSpecial = wdPaneNone Then
.ActivePane.View.Type = wdNormalView
Else
.View.Type = wdNormalView
End If
End With
Set wdDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
Application.StatusBar = False
End Sub
This should get you started. Place the code below in your Word document in the 'ThisDocument' module.
Add Excel reference to your Word VBA. In the VBA editor go to Tools and then References. Check the box next to Microsoft Excel 14.0 Object Library.
Private Sub Document_Open()
Dim intChoice As Integer
Dim strPath As String
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
End If
CopyWorksheetsToWord (strPath)
End Sub
Function CopyWorksheetsToWord(filePath As String)
Dim exApp As Excel.Application
Dim exWbk As Excel.Workbook
Dim exWks As Excel.Worksheet
Dim wdDoc As Word.Document
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdDoc = ActiveDocument
Set exApp = New Excel.Application
exApp.Visible = False
Set exWbk = exApp.Workbooks.Open(filePath)
For Each exWks In exWbk.Worksheets
exWks.UsedRange.Copy
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
exApp.CutCopyMode = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not exWks.Name = exWbk.Worksheets(exWbk.Worksheets.Count).Name Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
Next exWks
Application.StatusBar = "Cleaning up..."
Set exWks = Nothing
exWbk.Close
Set exWbk = Nothing
Set exApp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Function
Save file as macro-enabled file (.docm)
Close word file
Open word file and the code will run. First thing you'll see is a file open box to select the Excel file.
Tested code but there is no error checking.
Update per comment
Bookmarks can be located by name using the following syntax: wdDoc.Bookmarks("Bookmark2").Range
In this case I inserted a bookmark and labeled it Bookmark2
Updated Function Code:
Function CopyWorksheetsToWord(filePath As String)
Dim exApp As Excel.Application
Dim exWbk As Excel.Workbook
Dim exWks As Excel.Worksheet
Dim wdDoc As Word.Document
Dim bmRange As Range
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdDoc = ActiveDocument
Set exApp = New Excel.Application
exApp.Visible = False
Set exWbk = exApp.Workbooks.Open(filePath)
For Each exWks In exWbk.Worksheets
exWks.UsedRange.Copy
Set bmRange = wdDoc.Bookmarks("Bookmark2").Range
bmRange.Paste
exApp.CutCopyMode = False
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not exWks.Name = exWbk.Worksheets(exWbk.Worksheets.Count).Name Then
With wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
Next exWks
Application.StatusBar = "Cleaning up..."
Set exWks = Nothing
exWbk.Close
Set exWbk = Nothing
Set exApp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Function
Since your looping through sheets you'll probably need to play with formatting and how your stacking each section in the document but this should get you going.
I have created a PowerPoint with custom slide layouts. I want to be able to create a new slide using one of these custom layouts using Excel VBA, but I cannot figure out the correct syntax.
This is the code I currently have:
Sub runPPT()
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("SG2")
Dim pptName As String
Dim ppt As Object
Dim myPres As Object
Dim slds As Object
Dim sld As Object
MsgBox ("Please choose PowerPoint to open.")
pptName = openDialog()
Set ppt = CreateObject("PowerPoint.Application")
Set myPres = ppt.Presentations.Open(pptName)
Set slds = myPres.Slides
'This is where I want to add my custom layout
'My layouts all have similar names like "Gate 2 Main" if that helps
Set sld = slds.AddSlides(Slides.Count + 1, ActivePresentation.SlideMaster.CustomLayouts(1))
Application.ScreenUpdating = True
End Sub
Private Function openDialog()
Dim fd As Office.FileDialog
Dim txtFileName As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select the file."
' Clear out the current filters, and add our own.
.Filters.Clear
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
openDialog = txtFileName
End Function
I was able to fix my issue by changing my code to the following:
Sub runPPT()
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("SG2")
Dim pptName As String
Dim ppt As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim slds As PowerPoint.Slides
Dim sld As PowerPoint.slide
Dim oLayout As CustomLayout
MsgBox ("Please choose PowerPoint to open.")
pptName = openDialog()
Set ppt = CreateObject("PowerPoint.Application")
Set myPres = ppt.Presentations.Open(pptName)
Set slds = myPres.Slides
Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)
For Each oLayout In myPres.Designs("Gate Main").SlideMaster.CustomLayouts
If oLayout.Name = "Gate 2 Main" Then
sld.CustomLayout = oLayout
Exit For
End If
Next
Application.ScreenUpdating = True
End Sub
Private Function openDialog()
Dim fd As Office.FileDialog
Dim txtFileName As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select the file."
' Clear out the current filters, and add our own.
.Filters.Clear
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
openDialog = txtFileName
End Function
I want to Export large data stock from Access to Excel. I'm doing that with a form.
My code with "DoCmd.TransferSpreadsheet acExport..." works normally, but the program breaks off because of the large data stock.
Perhaps with queries I can solve this Problem, or what do you think?
I am thankful for each tip! =)
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'=======================
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'''PPT
Sub pptExoprort()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim slideNum As Integer
Dim chartName As String
Dim tableName As String
Dim PPTCount As Integer
Dim PPSlideCount As Long
Dim oPPTShape As PowerPoint.Shape
Dim ShpNm As String
Dim ShtNm As String
Dim NewSlide As String
Dim myChart As PowerPoint.Chart
Dim wb As Workbook
Dim rngOp As Range
Dim ro As Range
Dim p As Integer
Dim v, v1, v2, v3, Vtot, VcaGr
Dim ws As Worksheet
Dim ch
Dim w As Worksheet
Dim x, pArr
Dim rN As String
Dim rt As String
Dim ax
Dim yTbN As String
'Call InitializeGlobal
''start year offset
prodSel = shtSet.Range("rSelProd")
x = shtSet.Range("rngMap").Value
pArr = fretPrVal(x, prodSel)
TY = 11 'number of years in chart
ThisWorkbook.Activate
Set w = ActiveSheet
Set PPApp = GetObject("", "Powerpoint.Application") '******************
PPTCount = PPApp.Presentations.Count
If PPTCount = 0 Then
MsgBox ("Please open a PPT to export the Charts!")
Exit Sub
End If
Set PPPres = PPApp.ActivePresentation '******************
For j = 0 To UBound(pArr)
If j = 0 Then
rN = "janport"
slideNum = 3
yTbN = "runport"
Else
rN = "janprod" & j
slideNum = 3 + j
yTbN = "runprod" & j
End If
chartName = "chtSalesPort"
Set PPSlide = PPPres.Slides(slideNum) '**************
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
Set myChart = PPSlide.Shapes(chartName).Chart '******************
myChart.ChartData.Activate '********************
Set wb = myChart.ChartData.Workbook '***********
Set ws = wb.Worksheets(1) '**************
Set rngOp = w.Range(rN).Offset(0, 1).Resize(12, 6)
Set ro = rngOp
' v1 = ro.Offset(1, 22).Resize(Lc, 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$B$" & Ty + 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$" & Chr(Lc + 1 + 64) & "$" & Ty + 1)
ws.Range("B2:g13").ClearContents '***********
rngOp.Copy '**********
ws.Range("B2:g13").PasteSpecial xlPasteValues '******************
End Sub
Sub Picture62_Click()
Dim charNamel As String
Dim leftm As Integer
Dim toptm As Integer
charNamel = "Chart 1"
leftm = 35
toptm = 180
Call chartposition(leftm, toptm, charNamel)
End Sub
Sub chartposition(leftm, toptm, charNamel)
ActiveSheet.ChartObjects(charNamel).Activate
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim activslidenumber As Integer
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
' If newPowerPoint.Presentations.Count = 0 Then
' newPowerPoint.Presentations.Add
' End If
'Show the PowerPoint
newPowerPoint.Visible = True
On Error GoTo endd:
activslidenumber = Str(GetActiveSlide(newPowerPoint.ActiveWindow).SlideIndex)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(activslidenumber)
ActiveChart.ChartArea.Copy
On Error GoTo endddd:
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse).Select
endddd:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = leftm
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = toptm
GoTo enddddd:
endd:
MsgBox ("Please keep your PPT file opened")
enddddd:
End Sub
I'm trying to import multiple .msg files into an Excel Sheet (msg body per row)but so far the only reference found was this here, so my code so far let you:
Select the folder path (where the .msg are located)
Loop through all the .msg files
But I'm unable to figure out how to achieve my objective. Thanks in advance for the response.
Code:
Sub importMsg()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim i As Long
Dim inPath As String
Dim thisFile As String
Dim msg As MailItem
Dim OlApp As Object
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Main")
Set OlApp = CreateObject("Outlook.Application")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
Exit Sub
End If
On Error Resume Next
inPath = .SelectedItems(1) & "\"
End With
i = 1
thisFile = Dir(inPath & "*.msg")
Do While thisFile <> ""
i = i + 1
Dim MyItem As Outlook.MailItem
Set MyItem = Application.CreateItemFromTemplate(thisFile)
'Set MyItem = Application.OpenSharedItem(thisFile)
ws.Cells(i, 1).Value = MyItem.Body
'MyItem.Body
'MyItem.Subject
'MyItem.Display
thisFile = Dir
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
I found the error in the Do While Loop the variable thisFile wasn't maintaining the full path reference so I added the concatenation again and worked, code below:
Sub importMsg()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim i As Long
Dim inPath As String
Dim thisFile As String
Dim Msg As MailItem
Dim ws As Worksheet
Dim myOlApp As Outlook.Application
Dim MyItem As Outlook.MailItem
Set myOlApp = CreateObject("Outlook.Application")
Set ws = ThisWorkbook.Worksheets("Main")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
Exit Sub
End If
On Error Resume Next
inPath = .SelectedItems(1) & "\"
End With
thisFile = Dir(inPath & "*.msg")
i = 4
Do While thisFile <> ""
Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
ws.Cells(i, 1) = MyItem.Body
i = i + 1
thisFile = Dir()
Loop
Set MyItem = Nothing
Set myOlApp = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
I am a grad student and I collect a lot of data that is stored in txt files. I want to import the text files as a fixed width, columns a, b and c all are 12, then save those files as excel files and then move them into a master workbook. I found the following code that worked for making the master workbook but it does not import them in numerical order.
I am using Microsoft 2010.
Sub Merge2MultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Users\Kyle\Desktop\Scan Rate Study 1-14-16"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(MyPath & "\*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Consider using the FSO object to traverse the MyPath directory and copy over the .xls files. Currently, your set up was importing all Excel like files located in directory:
Sub Merge2MultiSheets()
Dim MyPath As String
Dim wbDst As Workbook, wbSrc As Workbook, wsSrc As Worksheet
Dim fso As Object, olFolder As Object, olFile As Object
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Users\Kyle\Desktop\Scan Rate Study 1-14-16"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Set fso = CreateObject("Scripting.FileSystemObject")
Set olFolder = fso.GetFolder(MyPath)
For Each olFile In olFolder.Files
If Right(olFile.Name, 4) = ".xls" Then
Set wbSrc = Workbooks.Open(olFile.Name)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
End If
Next olFile
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Set olFile = Nothing
Set olFolder = Nothing
Set fso = Nothing
End Sub