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)
Related
I have this challenge to create a macro to extract data from ppt.
I need to extract the data from tables in a ppt and paste them into Excel.
I can extract data and paste it into Excel, but the tables are printing one below the other, like this:
I want the tables to to printed like this:
The below image is from ppt how the tables are placed in ppt,
in similar way the tables need to be printed in the Excel spreadsheet:
I tried this:
Sub ExportToExcelSheet()
'Declare PPT variables
Dim pptPres As Presentation
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptPlaceholder As PlaceholderFormat
Dim pptTable As Table
'Declare Excel variables
Dim xlApp As Excel. Application
Dim xlBook As Excel. Workbook
Dim xlSheet As Excel. Worksheet
Dim xlRange As Excel.Range
'Access the active presentation
Set pptPres = Application.ActivePresentation
On Error Resume Next
Set xlApp = GetObject(, "EXCEL.Application")
If Err.Number = 429 Then
Err.Clear
Set xlApp = New Excel.Application
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets.Add
End If
Set xlBook = xlApp.Workbooks("Extract.xlsx")
Set xlSheet = xlBook.Worksheets("Sheet1")
For Each pptSlide In pptPres.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoTable Then
Set pptTable = pptShape.Table
pptShape.Copy
Set xlRange = xlSheet.Range("A100").End(xlUp)
If xlRange.Address <> "$A$1" Then
Set xlRange = xlRange.Offset(3, 0)
End If
xlSheet.Paste Destination:=xlRange
End If
Next
Next
xlSheet.Columns.Range("A1").ColumnWidth = 5
xlSheet.Columns.Range("B1").ColumnWidth = 25
xlSheet.Rows.RowHeight = 20
End Sub
Because xlRange is defined by searching the last used cell in Column A, you are only pasting to Column A and thus, your current output is one after the other down this column.
You can keep it this way and then reposition each table after they are in Excel by serching each title for "Sub*" and if found put it on row (say) 10 otherwise using a similar method to your last row, find the last column and offset it say, 3 columns to the right.
Something like this AFTER your existing for loop...
Dim RowCounter As Long
Dim BottomRowOfTable As Long
Dim LastColumn As Long
Dim MyArray As Variant
For RowCounter = 1 To xlRange 'You can reuse this as the last destination which would be the last header row in the list you pasted.
With xlSheet
If .Cells(RowCounter, 1).Value Like "Sub*" Then
BottomRowOfTable = .Cells(RowCounter, 1).End(xlDown).Row
LastColumn = .Cells(8, .Columns.Count).End(xlToLeft).Column
MyArray = .Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Value
.Range(.Cells(8, LastColumn + 2).Address).Resize(UBound(MyArray)).Value = MyArray
.Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Clear
ElseIf .Cells(RowCounter, 1).Value Like "Station*" Then
BottomRowOfTable = .Cells(RowCounter, 1).End(xlDown).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
MyArray = .Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Value
.Range(.Cells(1, LastColumn + 2).Address).Resize(UBound(MyArray)).Value = MyArray
.Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Clear
End If
End With
Next RowCounter
You will probably need to change some of the cell references so it targets the right cell to find the title and/or move each table to the correct location.
I also did not test with formatting per your current output to Excel.
I think there is probably a cleaner way to do this but this method can achieve your goal.
I have a sheet (Dashboard) that has multiple Pareto charts, another sheet (Data) brings in the range for each chart via a formula in standard $A$1:$B$2 format.
how do I use these ranges from the Sheet "Data" in the Pareto charts in the "Dashboard"?
Chart name is in Data B4
Chart Range is in Data C4
I have code for each chart for troubleshooting below is one from a single chart
Sub FirstChart()
Dim FirstChartName As String
Dim FirstChartRange As Range
FirstChartName = Sheets("Data").Range("B4")
Set FirstChartRange = Worksheets("Data").Range(Sheets("Data").Range("C4").Value)
Sheets("Dashboard").ChartObjects("FirstChart").Activate
ActiveChart.ChartArea.Select
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = FirstChartName
ActiveChart.SetSourceData Source:=FirstChartRange
End Sub
Thanks in advance.
UPDATE:
Thanks to #coross24 and #WIL.
i have uploaded the file based on their answers to https://gofile.io/d/8HfjQv
It seems you were slightly off when referencing the FirstChartRange parameter. Since the variable was bound as a Range, what you've done is reference the cell C4 as the range, rather than the string within that range, in turn trying to plot the string value within that cell! When running your code, I ran into a type error.
I've amended your code above and tested it out on a singe chart in my workbook and it seems to work okay. I've also early bound your worksheets so you don't have to repeat yourself in your code.
Sub FirstChart()
Dim FirstChartName As String
Dim FirstChartRange As String
Dim shtData As Excel.Worksheet
Dim shtDashboard As Excel.Worksheet
Dim chart As Excel.chart
Set shtData = ThisWorkbook.Sheets("Data")
Set shtDashboard = ThisWorkbook.Sheets("Dashboard")
' get chart name
FirstChartName = shtData.Range("B4").Value2
' get chart range
FirstChartRange = shtData.Range("C4").Value2
' change data for first chart
Set chart = shtDashboard.ChartObjects("FirstChart").chart
With chart
.HasTitle = True
.ChartTitle.Text = FirstChartName
.SetSourceData shtData.Range(FirstChartRange)
End With
End Sub
Good luck!
Try this One
Sub FirstChart()
Dim FirstChartName As String
Dim FirstChartRange As String
Dim shtData As Excel.Worksheet
Dim shtDashboard As Excel.Worksheet
Dim chart As Excel.chart
Set shtData = ThisWorkbook.Sheets("Data")
Set shtDashboard = ThisWorkbook.Sheets("Dashboard")
' get chart name
FirstChartName = shtData.Range("B4").Value2
' get chart range
FirstChartRange = shtData.Range("C4").Value2
' change data for first chart
Set chart = shtDashboard.ChartObjects("FirstChart").chart
With chart
.HasTitle = True
.ChartTitle.Text = FirstChartName
.SetSourceData FirstChartRange
End With
End Sub
Relik,
I've had to post another answer as my reputation isn't high enough to reply with a comment. There's an absolutely filthy work around.... it seems the data does actually populate the graph is you just bypass the error message, and then set the y-axis scale to auto. See below for the code:
Option Explicit
Sub FirstChart()
Dim FirstChartName As String
Dim FirstChartRange As String
Dim rng As Range
Dim r As Range
Dim shtData As Excel.Worksheet
Dim shtDashboard As Excel.Worksheet
Dim chart As Excel.chart
Dim tmp As Variant
Set shtData = ThisWorkbook.Sheets("Data")
Set shtDashboard = ThisWorkbook.Sheets("Dashboard")
' get chart name
FirstChartName = shtData.Range("B4").Value2
' get chart range
FirstChartRange = shtData.Range("C4").Value2
' change data for first chart
Set chart = shtDashboard.ChartObjects("FirstChart").chart
With chart
.HasTitle = True
.ChartTitle.Text = FirstChartName
On Error Resume Next
.SetSourceData shtData.Range(FirstChartRange)
On Error GoTo 0
.Axes(xlValue).MaximumScaleIsAuto = True
End With
End Sub
Hope this helps with your issue!
This is an example for creating a scatter plot.
It should get you going.
Adapt it to your needs.
Sub CreateChart()
Dim wscharts As Worksheet, wsdata As Worksheet
Set wscharts = Worksheets("Dashboard")
Set wsdata = Worksheets("Data")
Dim sh As Shape
Set sh = wscharts.Shapes.AddChart2(240, xlXYScatterLines)
sh.Select
Dim rngText As String
rngText = wsdata.Name & "!" & wsdata.Range("Data!$C$4").Value
ActiveChart.SetSourceData Source:=Range(rngText)
sh.Name = wsdata.Range("Data!$B$4").Value
End Sub
It works fine with the data as shown
I need to generate multiple powerpoint files by updating chart in 2nd slide on excel data available in each row(dynamic row counts)
I have a excel file with around 1000 rows(count is dynamic every time) and each row is a record, based on 1 row i have created a chart in excel itself which i need to copy in second slide of my existing ppt template. So in this way i need to generate 1000 ppts and save the files based on the name available in same row, can any one help me to resolve this query.
My logic is something like this.
Loop through all the rows
Create sheet
Create chart for first row
Copy paste in ppt fist slide
Then delete the chart or sheet in workbook
Repeat all the step till the end
Below is the code which i tried earlier where in i have created the chart in ppt and linked to the 1st row of my data file, but it only solves half of my problem that i can create only one report not multiple.
Sub Update()
Dim CName, pth
pth = ThisWorkbook.Path
Dim pptPres As PowerPoint.Presentation
Dim pptApp As PowerPoint.Application
Dim Sld As PowerPoint.Slide
Dim sh As PowerPoint.Shape
Dim wb As Workbook
Dim aLinks As Variant
Dim FName As String
Dim strPptTemplatePath As String
strPptTemplatePath = "C:\Users\DSS1080\Desktop\Business continuity planning\Report Template.pptx"
Application.ScreenUpdating = False
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = msoTrue
Set pptPres = pptApp.Presentations.Open(strPptTemplatePath, untitled:=msoTrue)
NewLink = pth & "\" & ThisWorkbook.Name
pptApp.Activate
For Each Sld In pptPres.Slides
For Each sh In Sld.Shapes
If sh.Type = msoChart Then
sh.Chart.ChartData.Activate
Set wb = sh.Chart.ChartData.Workbook
aLinks = wb.LinkSources(xlExcelLinks)
wb.Sheets(1).Cells(100, 100).Value = aLinks
Oldfile = Cells(100, 100).Value
wb.ChangeLink Name:=Oldfile, NewName:=NewLink, Type:=xlExcelLinks
wb.Sheets(1).Cells(100, 100).Clear
wb.Close False
Set wb = Nothing
sh.Chart.ChartData.Activate
Set wb = sh.Chart.ChartData.Workbook
wb.Close False
Set wb = Nothing
End If
Next
Next
FName = Sheets("Quadrant").Range("C1").Text
CName = Left(strPptTemplatePath, Len(strPptTemplatePath) - 19) & FName
pptPres.SaveAs CName, ppSaveAsDefault
pptPres.Close
Set pptPres = Nothing
pptApp.Quit
Set pptApp = Nothing
Application.ScreenUpdating = True
End Sub
Is there a way such that i can copy and paste multiple charts that are grouped in four as shown below from excel to my existing powerpoint slides 28 and slides 29? The name of the groups are group 16 for the left group, group 17 for the right group. I have tried to use Chrt.CopyPicture but it only copies charts separately to the slides instead of a group like the one outline on the 4 charts shown on the left side of the picture below. By the way, my only code only copies charts individually to slide 28.
Sub ExportChartsTopptSingleWorksheet()
'Declare PowerPoint Variables
Dim PPTApp As Object
Dim PPTPres As Object
Dim PPTShape As Object
Dim mySlide, myslide2 As Object
'Declare Excel Variables
Dim Chrt As ChartObject
If PPTApp Is Nothing Then _
Set PPTApp = CreateObject(class:="PowerPoint.Application")
On Error GoTo 0
PPTApp.Visible = True
'Create new presentation in the PowerPoint application.
Set PPTPres = PPTApp.Presentations.Open(Filename:="\\fab2crp-nas1\home22\kkang2\Profile\Desktop\myassignment3\mypresentationsample.pptx")
Set mySlide = PPTPres.Slides.Add(28, 1)
'Loop through all the CHARTOBJECTS in the ACTIVESHEET.
For Each Chrt In ActiveSheet.ChartObjects
'Copy the Chart
Chrt.CopyPicture '<------ method copy fail error here
'paste all the chart on to exisitng ppt slide 28
mySlide.Shapes.Paste
Next Chrt
End Sub
Currently, charts are copied individually to ppt slides
Expected
This worked for me.
Sub ExportChartsTopptSingleWorksheet()
Const PER_ROW As Long = 2 'charts per row in PPT
Const T_START As Long = 40 'start chart top
Const L_START As Long = 40 'start chart left
Dim PPTApp As Object
Dim PPTPres As Object
Dim PPTShape As Object
Dim mySlide, myslide2 As Object, i As Long
Dim Chrt As ChartObject, T As Long, L As Long
If PPTApp Is Nothing Then _
Set PPTApp = CreateObject(class:="PowerPoint.Application")
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add()
Set mySlide = PPTPres.Slides.Add(1, 1)
i = 0
For Each Chrt In ActiveSheet.ChartObjects
Chrt.Chart.CopyPicture
i = i + 1
'work out the top/left values
T = T_START + (Application.Floor((i - 1) / PER_ROW, 1)) * Chrt.Height
L = L_START + ((i - 1) Mod PER_ROW) * Chrt.Width
With mySlide.Shapes
.Paste
.Item(.Count).Top = T
.Item(.Count).Left = L
End With
Next Chrt
End Sub
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