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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.