Sub ToPowerPoint()
Dim pApp As PowerPoint.Application
Dim pSilde As PowerPoint.Slide
Dim pPres As PowerPoint.Presentation
'I have declared here pp Objects
Application.EnableEvents = False
Application.ScreenUpdating = False
'Turning off screen updating
Set pApp = New PowerPoint.Application
pApp.Visible = True
'Setting up new pp instance
pApp.Activate
Set pPres = pApp.Presentations.Add
Set pSlide = pPres.Slides.Add(1, ppLayoutBlank)
'Adding up new presentation and slide within pp
pSlide.Select
Dim wb As Excel.Workbook
Dim sh As Excel.Worksheet
Set wb = Workbooks("BC_WTB__DRAFT.xlsb")
'setting up here xl workbooks
'
wb.Activate
Worksheets("BS").Visible = True
Worksheets("BS").Select
Worksheets("BS").Range("G5:H5").Select
Selection.Copy
pSlide.Shapes.PasteSpecial ppPasteRTF
**'copying some cell values here and below**
Worksheets("BS").Range("G12").Select
Selection.Copy
pSlide.Shapes.PasteSpecial ppPasteEnhancedMetafile
pApp.ActiveWindow.Selection.ShapeRange.Top = 193
Worksheets("BS").Range("H12").Select
Selection.Copy
pSlide.Shapes.PasteSpecial ppPasteEnhancedMetafile
pApp.ActiveWindow.Selection.ShapeRange.Top = 193
'I need to align pasted objects in one horizontal line
'without using Top or Left methods
'I need help after copied cells are pasted in pp, to align them in
'some vertical and horizontal line without using top or left method.
End Sub
ExcelHelp.
If you are trying to aling objects in powepoint presentation you can use the native alingment and distribute functions.
Just adding this at the and of your code.
Dim myArray() As Variant, myRange As Object
myArray = Array("img1", "img2", "txt1")
Set myRange = ActivePresentation.Slides(1).Shapes.Range(myArray)
myRange.Distribute msoDistributeHorizontally, msoFalse
myRange.Distribute msoDistributeVertically, msoFalse
myRange.Align msoAlignLefts, msoFalse
You just need to change names of the defaut shapes in the array (names change because we have different languages).
If you need to aling left, or top or right use the last line, or distribute heights / widths
Related
Sub OO()
Dim oPPApp As Object, oPPPrsn As Object, oPPSlide As Object
Dim oPPShape As Object
Dim FlName As String
'~~> Change this to the relevant file
FlName = "C:\Users\lich_\Documents\test.pptx"
'~~> Establish an PowerPoint application object
On Error Resume Next
Set oPPApp = GetObject(, "PowerPoint.Application")
If Err.Number <> 0 Then
Set oPPApp = CreateObject("PowerPoint.Application")
End If
Err.Clear
On Error GoTo 0
oPPApp.Visible = True
Set oPPPrsn = oPPApp.Presentations.Open(FlName, WithWindow:=msoFalse)
Set oPPSlide = oPPPrsn.Slides(2)
With oPPSlide.Shapes("Chart1").Chart.ChartData
.ActivateChartDataWindow
.Workbook.Worksheets("Sheet1").Range("B2").Value = 0.1231
.Workbook.Close
End With
End Sub
As you can see above, I'm trying to edit the chart data in vba.
But since I have control many charts later, I would like to make the workbook invisible ( or not open it at all if possible )
With oPPSlide.Shapes("Chart1").Chart.ChartData
.ActivateChartDataWindow
.Workbook.Worksheets("Sheet1").Range("B2").Value = 0.1231
.Workbook.Close
End With
In this code I opened by "ActivateChartDataWindow" method and change the data which I want and Closed.
Is there any way to make the window invisible or to edit data without even opening?
Thank you for your help in advance.
It's possible to update existing chart data without Activate as per #mooseman's answer.
However, if the chart is new/inserted at runtime, as far as I know this cannot be accomplished with interop, as the AddChart method adds the chart and simultaneously creates/activates the Excel Workbook. While you may not need to call the Activate method, there is no way to insert or add a new chart that doesn't involve opening an Excel instance. There is no way around this, this is just how the UI functions and it is by design.
To Update Data in EXISTING Chart / ChartData
Below native PowerPoint VBA, but should port easily to Excel with proper reference(s)
Sub test()
Dim PPT As PowerPoint.Application
Dim pres As Presentation
Dim sld As Slide
Dim shp As Shape
Dim cht As Chart
Dim rng As Object ' Excel.Range
Set PPT = Application 'GetObject(,"PowerPoint.Application")
Set pres = ActivePresentation
Set sld = pres.Slides(1)
Set shp = sld.Shapes(1)
Set cht = shp.Chart
Call changeData(cht, 6.3)
pres.Slides.AddSlide pres.Slides.Count + 1, sld.CustomLayout
Set sld = pres.Slides(pres.Slides.Count)
sld.Shapes.AddChart().Chart.ChartData.Workbook.Application.WindowState = -4140
Set cht = sld.Shapes(1).Chart
Call changeData(cht, 3.9)
End Sub
Sub changeData(c As Chart, v As Double)
Dim rng As Object
With c.ChartData
Set rng = .Workbook.Worksheets(1).ListObjects(1).Range
rng.Cells(2, 2).Value = v ' etc.
.Workbook.Close
End With
End Sub
The requirement is to use the With block in VBA.
Some brief tests suggest this is also doable via Interop from python using win32com:
from win32com import client
ppt = client.Dispatch("PowerPoint.Application")
pres = ppt.ActivePresentation
sld = pres.Slides[0]
cht = sld.Shapes[0].Chart
cht.ChartData.Workbook.Worksheets[0].ListObjects[0].Range.Cells(2,2).Value = 9
And also in C#:
using Microsoft.Office.Interop.PowerPoint;
public static void foo(int value = 10)
{
Application ppt = new Microsoft.Office.Interop.PowerPoint.Application();
Presentation pres = ppt.ActivePresentation;
Slide sld = pres.Slides[1];
Chart cht = sld.Shapes[1].Chart;
{
cht.ChartData
.Workbook.Worksheets[1].ListObjects[1].Range.Cells(2, 2).Value = value;
}
}
To Minimize the ChartData / Workbook Window:
In practice I have not had reliable luck using the With method. If you cannot get it to work, then the next-best option is to minimize the window immediately:
Sub changeData(c As Chart, v As Double)
Dim rng As Object
With c.ChartData
.Activate
.Workbook.Application.WindowState = -4140 '## Minimize Excel
'## DO STUFF:
Set rng = .Workbook.Worksheets(1).ListObjects(1).Range
rng.Cells(2, 2).Value = v ' etc.
.Workbook.Close
End With
End Sub
Note that this method does briefly flash Excel on the screen, and this sucks because in that brief instant, it can intercept keystrokes/etc.
You don't have to activate the chartdata worksheet to make changes to it.
With oPPSlide.Shapes("Chart1").Chart.ChartData
'this updates the value in the datasheet
.Workbook.Sheets(1).Range("B2").Value = 0.1231
End with
You can also set the chartdata sheet to equal a range in an excel sheet
path2 = "C:\JohnDoe\Vasquez_061118.xlsm"
Set xlWorkBook = Workbooks.Open(FileName:=path2, ReadOnly:=True)
With oPPSlide.Shapes("Chart1").Chart.ChartData
'this updates the value in the datasheet
.Workbook.Sheets(1).Range("A1:B2").Value = xlWorkBook.Sheets(1).Range("A2:B3").Value
End With
Sub OO()
Dim oPPApp As Object, oPPPrsn As Object, oPPSlide As Object
Dim oPPShape As Object
Dim FlName As String
'~~> Change this to the relevant file
FlName = "C:\Users\lich_\Documents\test.pptx"
'~~> Establish an PowerPoint application object
On Error Resume Next
Set oPPApp = GetObject(, "PowerPoint.Application")
If Err.Number <> 0 Then
Set oPPApp = CreateObject("PowerPoint.Application")
End If
Err.Clear
On Error GoTo 0
oPPApp.Visible = True
Set oPPPrsn = oPPApp.Presentations.Open(FlName, WithWindow:=msoFalse)
Set oPPSlide = oPPPrsn.Slides(2)
With oPPSlide.Shapes("Chart1").Chart.ChartData
.ActivateChartDataWindow
.Workbook.Worksheets("Sheet1").Range("B2").Value = 0.1231
.Workbook.Close
End With
End Sub
As you can see above, I'm trying to edit the chart data in vba.
But since I have control many charts later, I would like to make the workbook invisible ( or not open it at all if possible )
With oPPSlide.Shapes("Chart1").Chart.ChartData
.ActivateChartDataWindow
.Workbook.Worksheets("Sheet1").Range("B2").Value = 0.1231
.Workbook.Close
End With
In this code I opened by "ActivateChartDataWindow" method and change the data which I want and Closed.
Is there any way to make the window invisible or to edit data without even opening?
Thank you for your help in advance.
It's possible to update existing chart data without Activate as per #mooseman's answer.
However, if the chart is new/inserted at runtime, as far as I know this cannot be accomplished with interop, as the AddChart method adds the chart and simultaneously creates/activates the Excel Workbook. While you may not need to call the Activate method, there is no way to insert or add a new chart that doesn't involve opening an Excel instance. There is no way around this, this is just how the UI functions and it is by design.
To Update Data in EXISTING Chart / ChartData
Below native PowerPoint VBA, but should port easily to Excel with proper reference(s)
Sub test()
Dim PPT As PowerPoint.Application
Dim pres As Presentation
Dim sld As Slide
Dim shp As Shape
Dim cht As Chart
Dim rng As Object ' Excel.Range
Set PPT = Application 'GetObject(,"PowerPoint.Application")
Set pres = ActivePresentation
Set sld = pres.Slides(1)
Set shp = sld.Shapes(1)
Set cht = shp.Chart
Call changeData(cht, 6.3)
pres.Slides.AddSlide pres.Slides.Count + 1, sld.CustomLayout
Set sld = pres.Slides(pres.Slides.Count)
sld.Shapes.AddChart().Chart.ChartData.Workbook.Application.WindowState = -4140
Set cht = sld.Shapes(1).Chart
Call changeData(cht, 3.9)
End Sub
Sub changeData(c As Chart, v As Double)
Dim rng As Object
With c.ChartData
Set rng = .Workbook.Worksheets(1).ListObjects(1).Range
rng.Cells(2, 2).Value = v ' etc.
.Workbook.Close
End With
End Sub
The requirement is to use the With block in VBA.
Some brief tests suggest this is also doable via Interop from python using win32com:
from win32com import client
ppt = client.Dispatch("PowerPoint.Application")
pres = ppt.ActivePresentation
sld = pres.Slides[0]
cht = sld.Shapes[0].Chart
cht.ChartData.Workbook.Worksheets[0].ListObjects[0].Range.Cells(2,2).Value = 9
And also in C#:
using Microsoft.Office.Interop.PowerPoint;
public static void foo(int value = 10)
{
Application ppt = new Microsoft.Office.Interop.PowerPoint.Application();
Presentation pres = ppt.ActivePresentation;
Slide sld = pres.Slides[1];
Chart cht = sld.Shapes[1].Chart;
{
cht.ChartData
.Workbook.Worksheets[1].ListObjects[1].Range.Cells(2, 2).Value = value;
}
}
To Minimize the ChartData / Workbook Window:
In practice I have not had reliable luck using the With method. If you cannot get it to work, then the next-best option is to minimize the window immediately:
Sub changeData(c As Chart, v As Double)
Dim rng As Object
With c.ChartData
.Activate
.Workbook.Application.WindowState = -4140 '## Minimize Excel
'## DO STUFF:
Set rng = .Workbook.Worksheets(1).ListObjects(1).Range
rng.Cells(2, 2).Value = v ' etc.
.Workbook.Close
End With
End Sub
Note that this method does briefly flash Excel on the screen, and this sucks because in that brief instant, it can intercept keystrokes/etc.
You don't have to activate the chartdata worksheet to make changes to it.
With oPPSlide.Shapes("Chart1").Chart.ChartData
'this updates the value in the datasheet
.Workbook.Sheets(1).Range("B2").Value = 0.1231
End with
You can also set the chartdata sheet to equal a range in an excel sheet
path2 = "C:\JohnDoe\Vasquez_061118.xlsm"
Set xlWorkBook = Workbooks.Open(FileName:=path2, ReadOnly:=True)
With oPPSlide.Shapes("Chart1").Chart.ChartData
'this updates the value in the datasheet
.Workbook.Sheets(1).Range("A1:B2").Value = xlWorkBook.Sheets(1).Range("A2:B3").Value
End With
I have an excel workbook with 20 sheets and I am trying to import these excel sheets into powerpoint using a VBA. I've been able to compose a piece of code which does almost exactly what I need to do, however I am unable to find the solution for the last part.. Hope you guys can help me out!
From each sheet I need to select a different range (which is visible in cell A1 and A2 of each sheet).
for example from excel sheet 1 I have in cell A1 "B3" and in cell A2 "D12", which means that for this sheet the VBA should copy range B3:D12.
In the next sheet exactly the same should happen, however it should adjust its range based on what I've given up in cell A1 and A2 of that sheet.
My code so far is as follows:
Sub PrintPPT()
'Step 1: Declare variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
Dim Cval1 As Variant
Dim Cval2 As Variant
Dim Rng1 As Range
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
'Step 3: Set the ranges for the data
Cval1 = ActiveSheet.Range("A1").Value
Cval2 = ActiveSheet.Range("A2").Value
Set Rng1 = ActiveSheet.Range("Cval1 : Cval2")
MyRange = "Rng1"
'Step 4: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select
Application.Wait (Now + TimeValue("0:00:1"))
'Step 5: Copy the range as picture
xlwksht.Range(MyRange).Copy
'Step 6: Count slides and add new blank slide as next available slide number
'(the number 12 represents the enumeration for a Blank Slide)
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'Step 7: Paste the picture and adjust its position
PPPres.ApplyTemplate ("C:\Users\Computer\Documents\Templates\Template.potx")
PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 80
pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
pp.ActiveWindow.Selection.ShapeRange.Width = 600
'Step 8: Add the title to the slide then move to next worksheet
Next xlwksht
'Step 9: Memory Cleanup
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
IF you want the values in cell A1 And A2, you can't put the variables in quotes when building your range.
Set Rng1 = ActiveSheet.Range("Cval1 : Cval2")
Will give you a Rng1 as Cval1 : Cval2
Set Rng1 = ActiveSheet.Range(Cval1 & ":" & Cval2)
Will give you (from your example) Rng1 = B3:D12
This should be all you need. I haven't tested it, so there may be some tweeking needed.
Sub PrintPPT()
'Step 1: Declare variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True
'Step 3: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets
MyRange = xlwksht.Range("A1").Value & ":" & xlwksht.Range("A2").Value
xlwksht.Range(MyRange).Copy
'Step 4: Count slides and add new blank slide as next available slide number
'(the number 12 represents the enumeration for a Blank Slide)
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'Step 5: Paste the picture and adjust its position
PPPres.ApplyTemplate ("C:\Users\Computer\Documents\Templates\Template.potx")
PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 80
pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
pp.ActiveWindow.Selection.ShapeRange.Width = 600
'Step 6: Add the title to the slide then move to next worksheet
Next xlwksht
'Step 7: Memory Cleanup
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing
End Sub
I am looking to copy and paste selected charts from Excel 2010 to Powerpoint 2010 as Microsoft Excel Chart Object formats into an active PPT slide. Ideally, I would like to be able to place these charts into specific positions on the active Powerpoint slide. I've scrounged the web but all if not most solutions are for all slides in a sheet to be pasted randomly on a PPT slide. I don't even have a code but if anyone can help, that would be awesome. Thanks!
Well, here's something: This is a pptGenerator-class that I wrote some time back.
In my scenario I wanted to right click specific charts in a workbook, have "Copy to presentation" as an option in a custom context menu, and add subsequent charts on subsequent slides in either the same presentation, or a new one.
These charts were captured in another class in order to create the context menu and have itself copied to the slide when passed to it.
Below is a slightly modified and stripped version, that should help you out to fix your specific situation by editing this class.
In a Class module:
'PowerPoint Generator class - Rik Sportel
'Maintains a PowerPoint application for Excel workbook.
Private WithEvents pptApp As PowerPoint.Application
Private ppt As PowerPoint.Presentation
Private pptPresentations As Collection 'Collection to add presentations to
Private p_currentPresentation As Boolean
'Make sure you don't add slides if there is no presentation.
Public Property Get CurrentPresentation() As Boolean
CurrentPresentation = p_currentPresentation
End Property
'Initialization
Private Sub Class_Initialize()
p_currentPresentation = False
Set pptApp = New PowerPoint.Application
Set pptPresentations = New Collection
End Sub
'Termination
Private Sub Class_Terminate()
Set pptPresentations = Nothing
Set pptApp = Nothing
End Sub
'Creates a new Presentation in the powerpoint app, and adds it to the pptPresentations collection. Add methods later to cycle through them.
Public Sub NewPresentation()
Set ppt = pptApp.Presentations.Add
pptPresentations.Add ppt
'Create presentation and use image stored within the current workbook as a background for it.
ThisWorkbook.Worksheets("BGItems").Shapes(1).Copy 'Copy the background
ppt.Windows(1).ViewType = ppViewSlideMaster
ppt.Windows(1).View.Paste 'Paste the background
ppt.Windows(1).ViewType = ppViewNormal
p_currentPresentation = True
End Sub
'Add a slide to the presentation, place passed chart on it.
Public Sub AddSlide(chartForSlide As Chart)
Dim nSlide As PowerPoint.Slide
Dim nChart As PowerPoint.Shape
'Create a new slide with the chart on it.
Set nSlide = pptApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
chartForSlide.ChartArea.Copy
nSlide.Shapes.Paste 'Paste the chart
Set nChart = nSlide.Shapes(1)
'Position the chart
With nChart
.Left = ppt.PageSetup.SlideWidth / 10
.top = ppt.PageSetup.SlideHeight / 10
.Width = ppt.PageSetup.SlideWidth / 100 * 80
.Height = ppt.PageSetup.SlideHeight / 2
End With
Set nChart = Nothing
Set nSlide = Nothing
End Sub
'Make sure to keep track of presentations properly if users interact with
'powerpoint in unexpected ways. Capture event and make sure the presentation object you write to will still exist.
Private Sub pptApp_PresentationClose(ByVal Pres As PowerPoint.Presentation)
For i = pptPresentations.Count To 1 Step -1
If pptPresentations.Item(i) Is Pres Then
pptPresentations.Remove i
End If
Next i
If Pres Is ppt Then
Set ppt = Nothing
p_currentPresentation = False
End If
End Sub
In my "factory" module. a regular code module:
Public Sub GetPowerpoint()
If pptApp Is Nothing Then Set pptApp = New pptGenerator
End Sub
How it's used:
'Pass a chart + optionally if it has to be a new presentation:
Public Sub CopyChartToPpt(tChart As Chart, Optional newPres As Boolean)
GetPowerpoint
If pptApp.CurrentPresentation = False Then pptApp.NewPresentation
If newPres = True Then pptApp.NewPresentation
pptApp.AddSlide tChart
End Sub
So where and how you obtain the selected chart is another thing, but as long as you manage to select the Chart from the ChartObject or Slide in your workbook, and pass it as a parameter to the above, you should be abled to fix it according to your own specs.
Other than my advise would be to check the VBA reference for your powerpoint version over at MSDN.
So here's a solution that worked for me. The macro copy + pastes selected range or chart into the active PowerPoint slide into a certain position. This reason I wanted to do this is that each quarter/month we generate reports for our clients and this helps to reduce the time required for copying + pasting and making the deck look nice. Hope this helps anyone else who make a ton of PPTs!
'Export and position into Active Powerpoint
'Prior to running macro, enable Microsoft Powerpoint Object Library in Tools - Reference
'Identifies selection as either range or chart
Sub ButtonToPresentation()
If TypeName(Selection) = "Range" Then
Call RangeToPresentation
Else
Call ChartToPresentation
End If
End Sub
Sub RangeToPresentation()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
'Error message if range is not selected
If Not TypeName(Selection) = "Range" Then
MsgBox "Please select a worksheet range and try again."
Else
'Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
'Reference active presentation
Set PPPres = PPApp.ActivePresentation
'Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
'Copy the range as a picture
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
'Paste the range
PPSlide.Shapes.Paste.Select
'Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Sub
Sub ChartToPresentation()
'Uses Late Binding to the PowerPoint Object Model
'No reference required to PowerPoint Object Library
Dim PPApp As Object 'As PowerPoint.Application
Dim PPPres As Object 'As PowerPoint.Presentation
Dim PPSlide As Object 'As PowerPoint.Slide
'Error message if chart is not selected
If ActiveChart Is Nothing Then
MsgBox "Please select a chart and try again."
Else
'Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
'Reference active presentation
Set PPPres = PPApp.ActivePresentation
'PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
'Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
'Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
'Paste chart
PPSlide.Shapes.Paste.Select
'Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Sub
I want to copy the print area for landscape in Excel to my Word document, where I run the code from.
I am using
wb.Sheets("Sheet1").Range("A1:N33").Copy
to copy the area, but as the column width changes, it's useless.
Update:
I am using this to calculate my usable dimensions in my Word Document
With ActiveDocument.PageSetup
UsableWidth = .PageWidth - .LeftMargin - .RightMargin
UsableHeight = .PageHeight - .TopMargin - .BottomMargin
End With
I tried to scale my image to fit with:
Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
Selection.ShapeRange.Height = UsableHeight
Selection.ShapeRange.Width = UsableHeight
It does not quite do it. The best approach would be to set the image range before it copies.
Update2:
Dim objExcel As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set wb = objExcel.Workbooks.Open("C:\test.xlsx")
Set ws = wb.Sheets("Sheet1")
This gives an error:
Set rngTemp = ws.Range("A1")
You can retrieve the print area information using this code:
Sub GetPrintArea()
Dim rngPrintArea As Range
'Put print area into range variable
Set rngPrintArea = Sheet1.Range(Sheet1.PageSetup.PrintArea)
'Perform operations on range - shows up in Immediate window:
Debug.Print rngPrintArea.Height
Debug.Print rngPrintArea.Width
Debug.Print rngPrintArea.Cells(rngPrintArea.Rows.Count, rngPrintArea.Columns.Count).Address
End Sub
This does not work if a print area is not already set - can you confirm if the Excel sheets are already set to landscape with a print area defined? If not, you'll need to find the paper dimensions and loop through cells until you find those which share the same Left and Top values (I think). You can set the PrintArea like this:
'Set print area
Sheet1.PageSetup.PrintArea = "$A1:$N33"
EDIT - This should do what you need now we know that the source dimensions are predefined - you'll need to set UseableWidth and UseableHeight in Word and either bring them into this sub using ByVal or a public variable:
Sub FindRange()
Dim rngTemp As Range, rngCopy As Range, rngTest As Range
Dim iCol As Integer, iRow As Integer
Set rngTemp = Sheet1.Range("A1")
'Get closest column
Do Until rngTemp.Left >= UseableWidth
Set rngTemp = rngTemp.Offset(0, 1)
Loop
iCol = rngTemp.Column
'Get closest row
Do Until rngTemp.Top >= UseableHeight
Set rngTemp = rngTemp.Offset(1, 0)
Loop
iRow = rngTemp.Row
Set rngCopy = Sheet1.Range("A1", Sheet1.Cells(iRow, iCol))
'Copy rngCopy into Word as you were before
End Sub