I have VBA code that contains the range Excel to PPT. So my question is how can I set a dynamic range instead of giving the array values here.
the example below code want same in dynamic:-
MySlideArray = Array(5, 7, 9, 11, 13, 15, 17, 18, 20, 22, 24, 26, 27, 28, 31)
MyRangeArray = Array(Sheet4.Range("A10:AS69"), Sheet9.Range("Q10:AH69"), Sheet10.Range("A1:AX65"), Sheet11.Range("A1:A12"), Sheet12.Range("A1:A12"), Sheet13.Range("A1:A12"), Sheet14.Range("A1:A12"), Sheet15.Range("A1:A12"), Sheet16.Range("A1:A12"), Sheet17.Range("A1:A12"), Sheet18.Range("A1:A12"), Sheet19.Range("A1:A12"), Sheet20.Range("A1:A12"), Sheet21.Range("A1:A12"), Sheet22.Range("A1:A12"))
I have a Report card that contains all the sheets with Excel range, so when I refer the array it should be capture the Report card Range
Ex
How to build a dynamic range?
ub copiSylwadau()
'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides
'SOURCE: www.TheSpreadsheetGuru.com
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
Dim MyArray As Variant
Dim iCounter As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then Exit
If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, aborting."
Exit Sub
End If
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.ActiveWindow.Panes(2).Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation
'List of PPT Slides to Paste to
'MyArray = Worksheets("control").Range("rng")
'MsgBox "MyArray"
MySlideArray = Array(5, 7, 9, 11, 13, 15, 17, 18, 20, 22, 24, 26, 27, 28, 31)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet4.Range("A1:A12"), Sheet9.Range("A1:A12"), Sheet10.Range("A1:A12"), Sheet11.Range("A1:A12"), Sheet12.Range("A1:A12"), Sheet13.Range("A1:A12"), Sheet14.Range("A1:A12"), Sheet15.Range("A1:A12"), Sheet16.Range("A1:A12"), Sheet17.Range("A1:A12"), Sheet18.Range("A1:A12"), Sheet19.Range("A1:A12"), Sheet20.Range("A1:A12"), Sheet21.Range("A1:A12"), Sheet22.Range("A1:A12"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
'If iCounter = iCounter < 2 Then
'If rCell And Not rCell.Offset(0, 2) Then
'copy slide template
'myPresentation.Slides(4).Copy
'Set obSlide = myPresentation.Slides.Paste(Index:=iCounter)
' iCounter = iCounter
' End If
'Paste to PowerPoint and position
On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=True)
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange
Set MySlideArray = myPresentation.Add(myPresentation.Count + 1)
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = 20
shp.Top = 70
shp.Width = 670
'shp.Height = ppAutoSizeShapeToFitText
End With
Next x
'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Cyflwyniad PowerPoint wedi eu greu!"
End Sub
Suggest you create named ranges directly then refer to those in your code.
Example: use the name "Sheet4Range" to name Sheet4.Range("A10:AS69")
In your code:
Sheet4.Range("Sheet4Range")
You can make the definition of the actual Sheet4Range range a Dynamic Named Range (DNR). There are many resources to learn how to construct a DNR. Here's one: https://www.excel-easy.com/examples/dynamic-named-range.html
Related
Private Sub Workbook_Open()
Dim workbThis As Workbook
Dim workbtarget As Workbook
'Dim RNG As Range
Dim PBR As Variant
' ASSIGN ROW FOR PAGEBREAK
PBR = Array(0, 38, 49, 38, 46, 38, 30, 52, 37, 42, 42, 42, 42, 33)
' Calculate workbook manually
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
.CalculateBeforeSave = True
End With
Sheets(1).Select
Calculate
Set workbThis = ActiveWorkbook
'Add workbook for copy data
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="C:\Temp\Report " & Format(Now(), "mm_dd_yyyy_hh") & ".xlsx"
'open a workbook that has same name as the sheet name
Set workbtarget = ActiveWorkbook
workbThis.Activate
Dim I As Integer
'For I = 1 To workbThis.Sheets.Count
' Copy workbook data to another sheet
Copy_sheet_data SH:=workbThis.Sheets("Report").Name, wbtarget:=workbtarget, wbThis:=workbThis
'Next I
'Next I
'close the workbook
workbtarget.Save
workbtarget.Close
workbThis.Save
Set workbtarget = Nothing
Set workbThis = Nothing
'Save current workbook
ThisWorkbook.Save
'Close workbook
Application.Quit
End Sub
I have two files. 1 file contains data with tabs named as company. The second file is to analyse the companies and I have there also tabs which are named in the same name as in tabs in file with copmanies data. In the file where I analyse data I have tab macro where I put information requires for macro. Companies name, file names. When the new copamny comes or the old one will disappear I want to do the same in macro as macro takes information from the tab macro from cells. Now what I want to have is that macro will copy for company A from file with companies data and paste into file with companies analyse. I have used to that loop FOR TO as then macro will copy and paste company A and then B,then C and so on and so forth. The macro is below. First part works. Opens file with data and active however then it doesnt work. I think I mixed variables but I have no idea how to fix it. Any ideas?
Sub CopyData()
Workbooks.Open Range("A10").Value
Dim wb As Workbook
Dim wbk As Workbook
Dim i As Integer
Dim FieldAVal As Worksheet
Dim FieldBVal As Worksheet
Dim Iter As Integer
For Each wb In Application.Workbooks
If wb.Name Like "*Reconciliation*" Then
wb.Activate
Exit For
End If
Next wb
Set wbk = Workbooks(Range("A9").Value)
Sheets("Macro").Select
Range("B6").Select
'define ranges with column numbers
Iter = Cells(1, 3).Value
For i = 1 To Iter
FieldAVal.Name = Cells(i + 14, 2).Value
FieldBVal.Name = Cells(i + 14, 3).Value
Workbooks(wbk).Worksheets(FieldBVal).Range("A1:V1000").Copy _
Destination:=ThisWorkbook.Worksheets(FieldAVal).Range("B2")
Next i
End Sub
I am not sure understanding
Public Sub CopyData()
On Error GoTo ErrHANDLER
Dim wb As Workbook
Dim wbk As Workbook
Dim i As Integer
Dim FieldAVal As Worksheet
Dim FieldBVal As Worksheet
Dim Iter As Integer
'add Variables
Dim secondFileName As String
Dim wbSecondFile As Workbook
Dim openedworkbookNameB As String
Dim openedworkbook As Worksheet
Dim pasteWorksheet As Worksheet
secondFileName = Range("A10").Value
'already opened workbook
openedworkbookNameB = Range("A9").Value
Set wbSecondFile = Workbooks.Open(secondFileName)
'Fail to open
If wbSecondFile Is Nothing Then
Exit Sub
End If
Set openedworkbook = Workbooks(openedworkbookNameB)
'no workbook
If openedworkbook Is Nothing Then
Exit Sub
End If
Call ThisWorkbook.Activate
ThisWorkbook.Sheets("Macro").Select
'ActiveSheet == "Macro" sheet
ActiveSheet.Range("B6").Select
Iter = VBA.Val(ActiveSheet.Cells(1, 3).Value)
For i = 1 To Iter
FieldAVal.name = ActiveSheet.Cells(i + 14, 2).Value
FieldBVal.name = ActiveSheet.Cells(i + 14, 3).Value
Set pasteWorksheet = ThisWorkbook.Worksheets(FieldAVal)
If Not pasteWorksheet Is Nothing Then
openedworkbook.Worksheets(FieldBVal).Range("A1:V1000").Copy _
Destination:=pasteWorksheet.Range("B2")
End If
Set pasteWorksheet = Nothing
Next i
Exit Sub
ErrHANDLER:
'When Raise error
Debug.Print Err.Number & " : " & Err.Description
'debug point Here
'press "F8" Key to Run a Macro Line by Line
Stop
Resume
End Sub
I have got the below code to copy the image from range of cells of excel to PPT, but the image pasted on the PPT does is of different dimensions.
Can someone tell me how can I fix size of the image when pasted in PPT.
I am pasting my code below for your reference.
Private Sub CommandButton1_Click()
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
'Unhiding the sheets
Worksheets("Sheet4").Visible = xlSheetVisible
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:C12")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Mupltiple Slides
'List of PPT Slides to Paste to
MySlideArray = Array(1, 2, 3)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet2.Range("A1:AB71"), Sheet1.Range("A1:AL70"), Sheet5.Range("A1:AE56"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBlank 'https://learn.microsoft.com/en-us/office/vba/api/powerpoint.ppslidelayout
'Copy Excel Range
'rng.Copy
MyRangeArray(x).Copy
Application.Wait (Now + TimeValue("0:00:03"))
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.count)
'Set position:
myShape.Left = 0
myShape.Top = 0
Next x
'Message Box
MsgBox ("Please is ready !!")
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
'Hiding the sheets back
Worksheets("Sheet4").Visible = xlSheetHidden
End Sub
I am trying to prepare a presentation from Excel. As of now VBA code is preparing "n number of "presentations as per no of times Loop runs. I want Code to generate just 1 presentation with all slides combined. Fist Macro "Addnumber" is run, which run Macro "ExcelRangeToPowerPoint". Its Macro "ExcelRangeToPowerPoint"which need to add slides for every loop of Macro "Addnumber"
Please Support
Sub AddNumber()
Dim Ws As Worksheet
Dim rngSel As Range
Dim rng As Range
Dim Num As Double
Dim i As Long
Dim j As Long
Dim lAreas As Long
Dim lRows As Long
Dim lCols As Long
Dim Arr() As Variant
Set rngSel = Worksheets("Sheet1").Range("A5:A30")
Do Until Range("A30") = Range("A3")
Num = 26
For Each rng In rngSel.Areas
If rng.Count = 1 Then
rng = rng + Num
Else
lRows = rng.Rows.Count
lCols = rng.Columns.Count
Arr = rng
For i = 1 To lRows
For j = 1 To lCols
Arr(i, j) = Arr(i, j) + Num
Next j
Next i
rng.Value = Arr
End If
Call ExcelRangeToPowerPoint
Next rng
Loop
End Sub
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
Dim rng As Range
Dim rng2 As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim mySize As PageSetup
Dim Addtitle As Shape
Dim DateT As String
'Copy Range from Excel
Set rng = Worksheets("Sheet1").Range("E2:M30")
Set rng2 = Worksheets("Sheet1").Range("F2")
Set rng3 = Worksheets("Sheet1").Range("B3")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11)
'11 = ppLayoutTitleOnly
'Change Theme and Layout
mySlide.ApplyTheme "C:\Users\davinder.sond\AppData\Roaming\Microsoft\Templates\Document Themes\DefaultTheme.thmx"
myPresentation.PageSetup.SlideSize = 3
myPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = rng2
myPresentation.Slides(1).Shapes.Title.Left = 59
myPresentation.Slides(1).Shapes.Title.Top = 10
myPresentation.Slides(1).Shapes.Title.Height = 30
myPresentation.Slides(1).Shapes.Title.Width = 673
With myPresentation.Slides(1).Shapes.Title
With .TextFrame.TextRange.Font
.Size = 24
.Name = "Arial"
.Bold = True
.Color.RGB = RGB(255, 255, 255)
End With
End With
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.LockAspectRatio = 0
myShape.Left = 12
myShape.Top = 55
myShape.Height = 475
myShape.Width = 756
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
DateT = Format("h:mm:ss")
'Clear The Clipboard
Application.CutCopyMode = False
myPresentation.SaveAs "C:\Project Control CCJV\ExperimentsPunch\" & rng3 & ".pptm"
PowerPointApp.Quit
End Sub
You are creating a new presentation everytime you call Set myPresentation = PowerPointApp.Presentations.Add within ExcelRangeToPowerPoint().
You can either try to open/close the Presentation outside of ExcelRangeToPowerPoint() and add a parameter to the function like ExcelRangeToPowerPoint(myPresentationObject) then you can simple add the slides there
or
you call the function AddNumber() within ExcelRangeToPowerPoint() of coarse the you need to loop there...
e.g.
Sub ExcelRangeToPowerPoint()
' some preparative code
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11)
For Each rng in rngSel.Areas
'Filling the presentation one slide at a time
AddSlide(rng)
Next
'Clear The Clipboard
Application.CutCopyMode = False
myPresentation.SaveAs "C:\Project Control CCJV\ExperimentsPunch\" & rng3 &
".pptm"
PowerPointApp.Quit
'some more code
End Sub
I adapted the following code to my requirements, with the exception of slide positioning. It places the range in a different location on each slide.
I'm trying to place the object a set distance from the left hand side and top of the slide.
Sub copiSylwadau()
'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides
'SOURCE: www.TheSpreadsheetGuru.com
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then Exit
If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, aborting."
Exit Sub
End If
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.ActiveWindow.Panes(2).Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation
'List of PPT Slides to Paste to
MySlideArray = Array(5, 7, 9, 11, 13, 15, 17, 18, 20, 22, 24, 26, 27, 28, 31)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet4.Range("A1:A12"), Sheet9.Range("A1:A12"), Sheet10.Range("A1:A12"), Sheet11.Range("A1:A12"), Sheet12.Range("A1:A12"), Sheet13.Range("A1:A12"), Sheet14.Range("A1:A12"), Sheet15.Range("A1:A12"), Sheet16.Range("A1:A12"), Sheet17.Range("A1:A12"), Sheet18.Range("A1:A12"), Sheet19.Range("A1:A12"), Sheet20.Range("A1:A12"), Sheet21.Range("A1:A12"), Sheet22.Range("A1:A12"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
'Paste to PowerPoint and position
On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.Paste
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = 20
shp.Top = 40
shp.Width = 679
End With
Next x
'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Cyflwyniad PowerPoint wedi eu greu!"
End Sub
Additionally, I've tried numerous ways to set the font and size of the text in the range being copied in. For example, tried adding the code below the myPresentation.PageSetup command, which was not recognised.
Shp.TextRange.Font.Size = 14
Shp.TextRange.Font.Name = "Arial"
Since you just paste the range from Excel to Powerpoint it is being pasted as a table and you need to format it that way.
Dim lRow As Long
Dim lCol As Long
Dim oTbl As Table
Set oTbl = shp.Table
For lRow = 1 To oTbl.Rows.Count
For lCol = 1 To oTbl.Columns.Count
With oTbl.Cell(lRow, lCol).Shape.TextFrame.TextRange
.Font.Name = "Arial"
.Font.Size = 14
End With
Next
Next
Try it like so:
PageSetup sets the SLIDE size, not the position of shapes on the slide; you don't need to mess with that.
'Paste to PowerPoint and position
On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.Paste
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange
'Center Object
shp.Left = 20
shp.Top = 40
shp.Width = 679