I am using this particular code by Belisarius:
Sub a()
Dim oSl As PowerPoint.Slide
Dim oSh As PowerPoint.Shape
Set oSl = ActivePresentation.Slides(1)
Set oSh = oSl.Shapes(1)
With oSh.OLEFormat.Object.WorkSheets(1)
.Range("A1").Value = .Range("A1").Value + 1
.Range("A2").Value = .Range("A2").Value - 1
End With
Set oSl = Nothing
Set oSh = Nothing
End Sub
I've embedded a line chart (with the ability to change values in excel) using insert menu in PowerPoint 2010. I'm getting an error that says OLEFormat (unknown member): Invalid Request. I know this has worked for someone out there but apparently what I've inserted is not an object. Why am I getting this error?
Accessing the underlying Excel worksheet is a little tricky - try this approach instead
Sub Test()
Dim myChart As Chart
Dim myChartData As ChartData
Dim myWorkBook As Object
Dim myWorkSheet As Object
Set myChart = ActivePresentation.Slides(1).Shapes(1).Chart
Set myChartData = myChart.ChartData
myChartData.Activate
Set myWorkBook = myChartData.Workbook
Set myWorkSheet = myWorkBook.Worksheets(1)
With myWorkSheet
.Range("A1").Value = .Range("A1").Value + 1
.Range("A2").Value = .Range("A2").Value - 1
End With
myWorkBook.Close
Set myWorkBook = Nothing
End Sub
Related
I have an excel sheet that has the data, I have a powerpoint presentation that has a few charts. I need to run a report eveyday, so i am trying to automate it. I wrote a vba script to copy and paste the data from excel sheet to the chart in powerpoint . But i am unable to change the selection region(the data that is displayed on the graph eventhough there may be more data).
I have written the following script. Any help that helps me change the data to be displayed on the chart is appreciated.
Private Sub CommandButton1_Click()
Dim r As Range
Dim powerpointapp As Object
Dim mypresentation As Object
Dim myslide As Object
Dim myshape As Object
Dim ppath As String
Dim titlesh As Object
Dim tdate As String
Dim chartsh As Object
tdate = Format(Date, "mmmm dd, yyyy")
ppath = "path to ppt"
Set powerpointapp = CreateObject(class:="PowerPoint.Application")
Set mypresentation = powerpointapp.Presentations.Open(ppath)
Set myslide = mypresentation.Slides(1)
Set titlesh = myslide.Shapes("Dateh")
titlesh.TextFrame.TextRange.Text = tdate
Set myslide = mypresentation.Slides(2)
Set chartsh = myslide.Shapes("Chart 6")
chartsh.Chart.ChartData.Workbook.Sheets(1).Cells.Clear
Set r = ThisWorkbook.Worksheets("Weekly Tracking").Range("B84:C158")
r.Copy
chartsh.Chart.ChartData.Workbook.Sheets(1).Range("A2:B74").Value = r.Value
powerpointapp.Visible = True
powerpointapp.Activate
Application.CutCopyMode = False
End Sub
Depends on what your data looks like. You may use .end or usedrange or a loop to looking for keyword in order to locate the end of data.
Some code just to demo the idea:
Dim lastline1 As Long, lastline2 As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Weekly Tracking")
lastline1 = ws.Cells(84, 2).End(xlDown).Row() 'Need to check whether row 84 is the last row, otherwise it may fly to 65536 or 1048576.
lastline2 = ws.UsedRange(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count).Row
Set r = ThisWorkbook.Worksheets("Weekly Tracking").Range("B84:C" & lastline2)
So when you right click a chart in Powerpoint and click Edit Data. A workbook will open up. I just want those data to be copied to my Excel file. Help me to extract every chart in each slide of powerpoint. Please help me Here's my code in PPT VBA so far:
Sub PowerpointToExcel()
Dim PPTPres As Presentation
Dim PPTSlide As Slide
Dim PPTShape As Shape
Dim PPTTable As Table
Dim PPTChart As Chart
Dim PPTPlaceHolder As PlaceholderFormat
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlRange As Excel.Range
Dim PPTChartData As MSForms.DataObject
Set PPTPres = Application.ActivePresentation
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
Set xlBook = xlApp.Workbooks("Book2.xlsx")
Set xlSheet = xlBook.Worksheets("Sheet2")
Set PPTChartData = New MSForms.DataObject
For Each PPTSlide In PPTPres.Slides
For Each PPTShape In PPTSlide.Shapes
If PPTShape.HasChart Then
Set PPTChart = PPTShape.Chart
Set xlRange = xlSheet.Range("A10000").End(xlUp)
If xlRange.Value <> "" Then
Set xlRange = xlRange.Offset(1, 0)
End If
With PPTPres.Slides(PPTSlide).Shapes(PPTShape).Chart.ChartData
.Activate
.Workbook.Sheets(1).Range("A2:E10").Copy
PPTChartData.GetFromClipboard
End With
SData = PPTChartData.GetText(1)
xlRange.Value = SData
xlRange.Offset(0, 1).Value = PPTSlide.Name
xlRange.Offset(0, 2).Value = PPTChart.ChartData
End If
Next
Next
End Sub
I'm new to VBA and I'm having difficulty trying to insert comments from data that I have in Excel onto a Word document. I am trying to write the VBA in Word and want it to extract data from a separate spreadsheet
Sub ConvertCelltoWordComment()
Dim Rng As Range
Dim wApp As Object
Dim strValue As String
Dim xlapp As Object
Dim xlsheet As Object
Dim xlbook As Object
'Opens Excel'
Set xlapp = GetObject("C:\Users\eugenechang\Desktop\...xlsx")
If Err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim i As Integer
For i = 1 To 5
With xlsheet
strValue = ActiveSheet.Cells(i, 1).Offset(1, 0)
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next i
End Sub
I'm trying to get it to work, but it is giving me an error "Object not defined". I've tried setting up an object within the strValue line below "With xlsheet", but am hitting a wall. Any help??
You have not assigned anything to xlsheet - so this (by default) equates to Nothing.
Try setting xlSheet to something meaningful. The following is only an example:
For i = 1 To 5
Set xlsheet = xlbook.Worksheets(i) ' <--- example here
With xlsheet
strValue = .Cells(i, 1).Offset(1, 0) '<-- don't use ActiveSheet
End With
'Insert comment into document'
ActiveDocument.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:="15"
ActiveDocument.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=5
ActiveDocument.Comments.Add Range:=Selection.Range, Text:=strValue
Next I
An important note here is that you also have not set xlbook - you must also assign something meaningful to xlbook.
Add a couple DocVariables to your Word file and run the script below, from Excel.
Sub PushToWord()
Dim objWord As New Word.Application
Dim doc As Word.Document
Dim bkmk As Word.Bookmark
sWdFileName = Application.GetOpenFilename(, , , , False)
Set doc = objWord.Documents.Open(sWdFileName)
'On Error Resume Next
objWord.ActiveDocument.variables("FirstName").Value = Range("FirstName").Value
objWord.ActiveDocument.variables("LastName").Value = Range("LastName").Value
' etc., etc., etc.
objWord.ActiveDocument.Fields.Update
'On Error Resume Next
objWord.Visible = True
End Sub
This ended up writing comments from an Excel file. Obviously the names have been changed for privacy reasons. Please let me know if I can simplify this better.
Sub ConvertExceltoWordComment()
Dim wApp As Word.Application
Dim xlApp As Excel.Application
Dim PgNum As Integer
Dim LineNum As Integer
Dim objSelection As Word.Document
Dim strpgSearch As Long
Dim strlinSearch As Long
Dim myRange As Range
Dim XlLog As Excel.Worksheet
Dim RowCount As Long
'Opens Copied Word document'
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Dim SaveDoc As Excel.Workbook
Set SaveDoc = xlApp.Workbooks.Open("FilePath.xlsm") 'Type filepath of document here'
Set XlLog = SaveDoc.Sheets("Worksheet_Name") 'Type Sheetname here'
RowCount = XlLog.Range("A1048576").End(xlUp).Row
If RowCount > 0 Then
Dim iTotalRows As Long
iTotalRows = XlLog.Rows.Count 'Get total rows in the table'
Dim txt As Variant
Dim iRows As Long
End If
Dim i As Integer
'Insert comment into Word document'
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
If Err Then
Set wApp = CreateObject("Word.Application")
End If
Set objSelection = ActiveDocument
For iRows = 3 To iTotalRows
txt = XlLog.Cells(iRows, 8).Text 'Grabs appropriate comment text'
objSelection.Activate
objSelection.SelectAllEditableRanges
strpgSearch = XlLog.Cells(iRows, 2) 'Grabs appropriate Page number'
strlinSearch = XlLog.Cells(iRows, 3) 'Grabs appropriate Line number'
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext,
Name:=strpgSearch
objSelection.ActiveWindow.Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative,
Count:=strlinSearch
Set myRange = ActiveWindow.Selection.Range
ActiveDocument.Comments.Add Range:=myRange, Text:=txt
Next iRows
Set xlApp = Nothing
Set SaveDoc = Nothing
Set XlLog = Nothing
Set objSelection = Nothing
Set myRange = Nothing
Set wApp = Nothing
SaveDoc.Close
End Sub
Sub jede_Grafik_nach_PowerPoint()
'Extras - Verweise: Microsoft PowerPoint x.x Object Library
Dim Grafik As Shape
Dim PP As Object
Set PP = CreateObject("Powerpoint.Application")
Dim PP_Datei As PowerPoint.Presentation
Dim PP_Folie As PowerPoint.Slide
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set PP_Datei = PP.Presentations.Open("C:\Users\akaygun\Desktop\test.pptm")
PP.Visible = msoTrue
'Set PP_Datei = PP.ActivePresentation wenn akt. Präsi sein soll
For Each ws In wb.Sheets
If Left(ws.Name, 3) = "MLK" Then
'neue Folie einfügen
PP_Datei.Slides(3).Copy
PP_Datei.Slides.Paste
Set PP_Folie = PP_Datei.Slides(PP_Datei.Slides.Count)
'copypaste
ws.Shapes("Stunden").Copy
PP_Folie.Shapes.Paste
PP_Folie.Shapes("Stunden").Top = 315.1991
PP_Folie.Shapes("Stunden").Left = 22.17449
ws.Shapes("Tage").Copy
PP_Folie.Shapes.Paste
PP_Folie.Shapes("Tage").Top = 10.16945
PP_Folie.Shapes("Tage").Left = -2.806772
End If
Next ws
End Sub
Dear Community,
I am trying to paste diagramms from excel to Powerpoint via VBA automatically.
When running this Sub it always says : "Remote server Computer doesnt exist"
'462'
I already tried to set a New Presentation instead of an Object but it did not help.
I'm fairly new to programming. Could you, please, help me identify the problem and possibly solve it. The macro below is supposed to extract tables from an e-mail folder. The first two parts work pretty well: I can open up the Excel export file and choose the email folder. However, export to the file fails as a target spreadsheet appears not to be recognized as an object. Thank you in advance.
Sub FolderEmptyCellTable()
Dim Mails As Outlook.MailItem
Dim NSP As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim i As Integer
Dim WordDoc, Selection, XL, Tabl, WL, WB As Object
'Open up an Excel file
Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set WB = XL.Workbooks.Open("C:\User\Desktop\Task\File.xlsx")
'Choose the export folder
Set NSP = Application.GetNamespace("MAPI")
Set Folder = NSP.PickFolder
'Run through e-mails collecting tables
For Each Mails In Folder.Items
Set WordDoc = Mails.GetInspector.WordEditor
If WordDoc.Tables.Count >= 1 Then
For i = 1 To WordDoc.Tables.Count
Set Tabl = WordDoc.Tables(i)
Tabl.Range.Copy
'Insert*emphasized text* each table to a separate sheet
Set WL = WB.Sheets(i)
'Here is where the error 424 occurs: Object required
**WL.Range("a1").End(xlDown).Offset(1, 0).Select**
Selection.Parent.PasteSpecial Format:="Text", Link:=False, _
DisplayAsIcon:=False
Next i
Else: MsgBox "No tables found"
Exit Sub
End If
Next Mails
End Sub
Declare like this:
Dim WordDoc As Object
Dim Selection As Object
Dim XL As Object
Dim Tabl As Object
Dim WL As Worksheet
Dim WB As Workbook
Thus, you will make sure that they are objects indeed. In your code, only WB is object, the others are of type Variant.
Thanks to a colleague of mine, the issue has been resolved.
Sub FolderEmptyCellTable()
Dim Mails As Outlook.MailItem
Dim NSP As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim XL As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim WL As Object
Dim WordDoc As Object
Dim Tabl As Object
Dim i As Integer
Dim Selection As Object
Set XL = CreateObject("Excel.Application")
XL.Visible = True
Set WB = Workbooks.Open("C:\User\Desktop\Task\File.xlsx")
Set NSP = Application.GetNamespace("MAPI")
Set Folder = NSP.PickFolder
Dim lastRow As Integer
For Each Mails In Folder.Items
Set WordDoc = Mails.GetInspector.WordEditor
If WordDoc.Tables.Count >= 1 Then
For i = 1 To WordDoc.Tables.Count
Set Tabl = WordDoc.Tables(i)
Tabl.Range.Copy
Set WS = WB.Worksheets(i)
lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1
WS.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
Next i
Else
MsgBox "No tables found"
GoTo LabelNext
End If
LabelNext:
Next Mails
End Sub