My code is suppose to create sheets, then charts on sheets with name "Sheet..." and then create a powerpoint. then it deletes all sheets and starts all over again. The charts creation part works, but when it comes to creating a powerpoint, the code hops over the IF-statement. It works the first round but after that it jumps over IF.
Dim ppt As PowerPoint.Application
Set ppt = New PowerPoint.Application
ppt.Visible = msoTrue
'Change template source if necessary
ppt.Presentations.Open "C:\Desktop\Template\PowerPoint_Template.potx", _
Untitled:=msoTrue
ppt.Activate
Dim ppt_pres As PowerPoint.Presentation
Set ppt_pres = ppt.ActivePresentation
Dim ppt_layout As CustomLayout
Set ppt_layout = ppt_pres.Slides(2).CustomLayout
Dim ppt_slide As PowerPoint.Slide
Set ppt_slide = ppt_pres.Slides.AddSlide(2, ppt_layout)
Dim ppt_shape As PowerPoint.Shape
Set ppt_shape = ppt_slide.Shapes(1)
Dim ppw As Object
Set ppw = ppt_pres.Windows(ppt_pres.Windows.Count)
Dim wsPIA As Worksheet
Set wsPIA = Sheet4
'Naming title slide
ppt_pres.Slides(1).Shapes(3).TextFrame.TextRange.Text = wsPIA.Range("C2")
ppt_pres.Slides(1).Shapes(2).TextFrame.TextRange.Text = wsPIA.Range("I2")
'Identifying number of sheets that contain newly created charts
Dim j As Integer, vNames() As Variant, ws As Worksheet, picture As Shape
j = 0
For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, 5) = "Sheet" Then
j = j + 1
ReDim Preserve vNames(j)
vNames(j) = ws.Name
End If
Next ws
Application.DisplayAlerts = False
'Looping copypaste of charts from excel to powerpoint
For Each ws In Worksheets
If Left(ws.Name, 5) = "Sheet" Then
ws.Select
For Each picture In ActiveSheet.Shapes
picture.Copy
ppw.View.GotoSlide ppt_pres.Slides.Count - 1
ppt_slide.Shapes.PasteSpecial ppPasteEnhancedMetafile
ppt_slide.Shapes(7).Height = 390
ppt.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoCTrue
ppt.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
ppt_slide.Shapes(7).Top = ppt_slide.Shapes(7).Top + 14
ppt_slide.Shapes.Title.TextFrame.TextRange.Text = wsPIA.Range("C2")
ppt_slide.Shapes(4).TextFrame.TextRange.Text =wsPIA.Range("I2")
ppw.View.GotoSlide ppt_pres.Slides.Count - 1
Set ppt_slide = ppt_pres.Slides.AddSlide(ppt_pres.Slides.Count - 1, ppt_layout)
Next
End If
Next
'Deleting blank slides from the end
ppt_pres.Slides.item(ppt_pres.Slides.Count - 1).Delete
ppt_pres.Slides.item(ppt_pres.Slides.Count - 1).Delete
With ppt_pres
.SaveAs ("C:\Desktop\Presentations\Pres1.pptx")
.Close
End With
The first round, line:
If Left(ws.Name, 5) = "Sheet" Then ws. Select
is true but after the first iteration, it skips that and goes straight to
'Deleting blank slides from the end
Related
I am having trubbles with a VBA project. My goal is to make a powerpoint from an excel. Each line in the excel make a new slide, and all info are automatically placed.
All rows have the same column number.
Only one sheet in workbook, so no problem with Activesheet.name.
I have pictures and text in random order, this is why I used ppPastedefault for the type of the shape.
Some cells can be empty, this is why I used the on error.
Program launch, you chose the slide template. Then, fo each cells of the first row from excel, you place the shape (text or picture) where you want on the powerpoint slide. Positions are saved in arrays. When all shapes from the first row are placed into the slide, it automatically make all the others slides (all shapes are placed in good position).
this is working "fine", but random errors appears :
Private Sub CommandButton1_Click()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.slide
Dim Wks As Worksheet
Dim Ncol As Integer, Nrow As Integer, Y As Integer
Dim ExcRng As Variant, Tpath As Variant, Plage As Variant
Dim PLShape() As Variant, PTShape() As Variant, PHShape() As Variant
Dim myShape As Object
Set Wks = Sheets(ActiveSheet.Name)
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
'define row, column and choice of the ppt layout. Also dimensioning the Arrays'
Ncol = Wks.Cells(1, Columns.Count).End(xlToLeft).Column
Nrow = Wks.Cells(Rows.Count, "B").End(xlUp).Row
Set Plage = Wks.Range("B1:B" & Nrow)
Tpath = Application.GetOpenFilename(".potx,*.potx", , "Choisissez le template")
Y = 0
ReDim PTShape(Ncol - 1)
ReDim PLShape(Ncol - 1)
ReDim PHShape(Ncol - 1)
For Each Cell In Plage
'Loop through all rows'
Set PPTSlide = PPTPres.Slides.Add(Y + 1, ppLayoutBlank)
With PPTSlide
PPTSlide.ApplyTemplate (Tpath)
PPTSlide.CustomLayout = PPTPres.SlideMaster.CustomLayouts(1)
End With
Y = Y + 1
'Loop through all columns of each rows'
For x = 0 To Ncol - 1
Set ExcRng = Wks.Cells(Cell.Row, x + 1)
'On error is used to pass cells that are empty. Maybe I could test ExcRng instead, but can't make it work'
On Error GoTo suite:
'the problem should be around here i guess'
ExcRng.Copy
DoEvents
PPTSlide.Shapes.PasteSpecial DataType:=0
Set myShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
'If statement, if this is the first slide, then you place all shape one by one. If not, all shapes are placed automatically with, "copying" the first slide'
If Y = 1 Then
MsgBox "Enregistrer position"
PTShape(x) = myShape.Top
PLShape(x) = myShape.Left
PHShape(x) = myShape.Height
Else
myShape.Top = PTShape(x)
myShape.Left = PLShape(x)
myShape.Height = PHShape(x)
End If
suite:
On Error GoTo -1
Application.CutCopyMode = False
Next x
Next Cell
End Sub
I have 2 issues with the program, and i can't solve those :
sometime, the shape (text) are not in a textbox but are in a table shape, keeping format from excel.
sometime, shapes (both text or picture) are missing
This is completly random.
On other topics, solutions are :
put a Doevents after the copy, this is not working very well. This might have improve stability, but I still have errors.
put a Application.wait for 1 or 2 seconde, not working and this solution is not good for me.
put a Application.CutCopyMode = False after the shapes.pastespecial, also not working.
That's all I could do. Maybe I have a problem into the definition of shapes,slides or even the object myShapeis badly defined, but as the failure is random, this is very hard to control.
Any idea ?
Thanks in advance for the help,
In case someone has the same issue, I think this solve the problem :
For each cell, I check if it contains picture and if it is empty or not.
If it contains a picture, it is copied with DataType:=ppPasteDefault
If it is not empty, it is copied with DataType:=ppPasteText
If it is empty, it is copied with DataType:=ppPasteEnhancedMetafile
So the loop go through everything, even empty cells and does not need the error handler anymore.
Now, you can use the error handler to restart the loop if there is an error in the copy/paste process. This is not the most beautiful solution, but it is working so far.
However, if something is going wrong, the program will loop indefinitely... you have to declare all your shapes / object / text / picture well and use dataType:= correctly.
`Private Sub CommandButton1_Click()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.slide
Dim cshape As Shape
Dim cflag As Boolean
Dim Wks As Worksheet
Dim Ncol As Integer, Nrow As Integer, Y As Integer
Dim ExcRng As Variant, Tpath As Variant, Plage As Variant
Dim PLShape() As Variant, PTShape() As Variant, PHShape() As Variant
Dim myShape As Object
Dim Eshape As Shape
Set Wks = Sheets(ActiveSheet.Name)
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
Ncol = Wks.Cells(1, Columns.Count).End(xlToLeft).Column
Nrow = Wks.Cells(Rows.Count, "B").End(xlUp).Row
Set Plage = Wks.Range("B1:B" & Nrow)
Tpath = Application.GetOpenFilename(".potx,*.potx", , "Choisissez le template")
Y = 0
ReDim PTShape(Ncol - 1)
ReDim PLShape(Ncol - 1)
ReDim PHShape(Ncol - 1)
On Error GoTo reprise:
For Each Cell In Plage
Set PPTSlide = PPTPres.Slides.Add(Y + 1, ppLayoutBlank)
'DoEvents'
With PPTSlide
PPTSlide.ApplyTemplate (Tpath)
PPTSlide.CustomLayout = PPTPres.SlideMaster.CustomLayouts(1)
'DoEvents'
End With
Y = Y + 1
For x = 0 To Ncol - 1
reprise:
On Error GoTo -1
Set ExcRng = Wks.Cells(Cell.Row, x + 1)
'DoEvents'
ExcRng.Copy
DoEvents
cflag = False
For Each cshape In Wks.Shapes
If cshape.TopLeftCell.Address = Wks.Cells(Cell.Row, x + 1).Address Then
cflag = True
GoTo suite:
End If
Next
suite:
If cflag Then
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteDefault
'DoEvents'
Else
If Wks.Cells(Cell.Row, x + 1) <> 0 Then
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteText
'DoEvents'
Else
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'DoEvents'
End If
End If
Set myShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
If Y = 1 Then
MsgBox "Enregistrer position"
PTShape(x) = myShape.Top
PLShape(x) = myShape.Left
PHShape(x) = myShape.Height
Else
myShape.Top = PTShape(x)
myShape.Left = PLShape(x)
myShape.Height = PHShape(x)
'DoEvents'
End If
Application.CutCopyMode = False
Next x
Next Cell
End Sub`
Thanks,
For some reason every column with data is being stored into columnsToCopy and unionVariable. At the top levels in Locals, I can see that it recognizes the column I actually want, but when I go deeper into say Cells -> WorkSheet -> UsedRange -> Value2 it will now show that all columns in my workbook are stored. This is the piece of code that I have assigning columnsToCopy, all the way to assigning unionVariable and then Copying it:
checkOne = iq_Array(0)
hasIQs = Left(checkOne, 3) = "iq_"
Dim columnsToCopy As Collection
Set columnsToCopy = New Collection
If hasIQs Then
' paste inital column into temporary worksheet
columnsToCopy.Add ShRef.Columns(1)
End If
' loop for each iq_ in the array
For arrayLoop = LBound(iq_Array) To UBound(iq_Array)
' Take copy of potential ref and adjust to standard if required
checkStr = iq_Array(arrayLoop)
If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr
' Look for existence of corresponding column in local copy array
pCol = 0
For iCol = 2 To colNumb
If checkStr = IQRef(iCol) Then
pCol = iCol
Exit For
End If
Next iCol
If pCol > 0 Then
' Paste the corresponding column into the forming table
columnsToCopy.Add ShRef.Columns(pCol)
End If
Next arrayLoop
If columnsToCopy.Count > 1 Then 'data was added
' Copy table
Dim unionVariable As Range
Set unionVariable = columnsToCopy(1)
For k = 2 To columnsToCopy.Count
Set unionVariable = xlApp.Union(unionVariable, columnsToCopy(k))
Next k
unionVariable.Copy ' all the data added to ShWork
The reason I'm looking into this, is because when I Union(unionVariable, columnToCopy(k)) I'm not getting something that would be equivalent to Range("A:A","D:D","Z:Z") , instead I'm getting Range("A:Z").
Any help is appreciated
My full code:
Option Explicit
Private Sub averageScoreRelay()
' 1. Run from PPT and open an Excel file
' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56,iq_72".
' 3. find those words and numbers in the opened Excel file after splitting and re-formating string.
' 3. Copy column into a new sheets and repeat for all "iq_'s" until sheets 2 has a table.
' 4. Copy table from xl Paste Table into ppt
' 5. Do this for every slide
'Timer start
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ShRef As Excel.Worksheet
Dim pptPres As Object
Dim colNumb As Long
Dim rowNumb As Long
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
'xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("C:\Users\Andre Kunz\Desktop\Gate\Macros\averageScores\pptxlpratice\dummy2.xlsx", True, False, , , , True, Notify:=False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
xlApp.DisplayAlerts = False
'Find # of iq's in workbook
Set ShRef = xlWB.Worksheets("Sheet1")
colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column
rowNumb = ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp).Row
Dim IQRef() As String
Dim iCol As Long
Dim IQRngRef() As Range
ReDim IQRef(colNumb)
ReDim IQRngRef(colNumb)
' capture IQ refs locally
For iCol = 2 To colNumb
Set IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol))
IQRef(iCol) = ShRef.Cells(1, iCol).Value
Next iCol
'Make pptPres the ppt active
Set pptPres = PowerPoint.ActivePresentation
'Create variables for the slide loop
Dim pptSlide As Slide
Dim Shpe As Shape
Dim pptText As String
Dim iq_Array As Variant
Dim arrayLoop As Long
Dim myShape As Object
Dim i As Long
Dim lRows As Long
Dim lCols As Long
Dim k As Long
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
i = 0
pptSlide.Select
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
If Not Shpe.HasTextFrame Then GoTo nextShpe 'boom, one less nested If statement
If Not Shpe.TextFrame.HasText Then GoTo nextShpe ' boom, another nested If statement bites the dust
'Set pptText as the Text in the box, then make it lowercase and trim Spaces and Enters
pptText = Shpe.TextFrame.TextRange
pptText = LCase(Replace(pptText, " ", vbNullString))
pptText = Replace(Replace(Replace(pptText, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)
'Identify if within text there is "iq_"
If InStr(1, pptText, "iq_") <= 0 Then GoTo nextShpe
'set iq_Array as an array of the split iq's
iq_Array = Split(pptText, ",")
Dim hasIQs As Boolean
Dim checkStr As String
Dim pCol As Long
Dim checkOne
checkOne = iq_Array(0)
hasIQs = Left(checkOne, 3) = "iq_"
Dim columnsToCopy As Collection
Set columnsToCopy = New Collection
If hasIQs Then
' paste inital column into temporary worksheet
columnsToCopy.Add ShRef.Columns(1)
End If
' loop for each iq_ in the array
For arrayLoop = LBound(iq_Array) To UBound(iq_Array)
' Take copy of potential ref and adjust to standard if required
checkStr = iq_Array(arrayLoop)
If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr
' Look for existence of corresponding column in local copy array
pCol = 0
For iCol = 2 To colNumb
If checkStr = IQRef(iCol) Then
pCol = iCol
Exit For
End If
Next iCol
If pCol > 0 Then
' Paste the corresponding column into the forming table
columnsToCopy.Add ShRef.Columns(pCol)
End If
Next arrayLoop
If columnsToCopy.Count > 1 Then 'data was added
' Copy table
Dim unionVariable As Range
Set unionVariable = columnsToCopy(1)
For k = 2 To columnsToCopy.Count
Debug.Print k & " : " & unionVariable.Address & " + " & columnsToCopy(k).Address
Set unionVariable = xlApp.Union(unionVariable, columnsToCopy(k))
Debug.Print " --> " & unionVariable.Address
Next k
unionVariable.Copy ' all the data added to ShWork
tryAgain:
ActiveWindow.ViewType = ppViewNormal
ActiveWindow.Panes(2).Activate
Set myShape = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
On Error GoTo tryAgain
'Set position:
myShape.Left = -200
myShape.Top = 150 + i
i = i + 150
End If
nextShpe:
Next Shpe
nextSlide:
Next pptSlide
xlWB.Close
xlApp.Quit
xlApp.DisplayAlerts = True
'End Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Output from Debugger:
2 : $A:$A + $B:$B
--> $A:$B
3 : $A:$B + $AF:$AF
--> $A:$B,$AF:$AF
2 : $A:$A + $C:$C
--> $A:$A,$C:$C
2 : $A:$A + $D:$D
--> $A:$A,$D:$D
3 : $A:$A,$D:$D + $L:$L
--> $A:$A,$D:$D,$L:$L
Here is another option doesn't have the additional overhead of creating a temporary workbook/worksheet.
Note: It may not be perfect -- in my testing it does not preserve cell background color but it does preserve text/font formats, and this appears consistent with the PasteSpecial(ppPasteHtml) method.
Note also: this assumes you can use a Table in PowerPoint to store the pasted data, and that all columns in your union range have the same number of rows. If you're just dumping the data in to a textbox or whatever sort of shape, this won't work.
But the idea is that once we have our "union", we can iterate over the Areas, and the Columns in each area, performing the Copy and Paste operation against each individual column.
Here is my data in Excel, I will create a union of the highlighted cells:
Here is the output in PowerPoint where I removed the borders from the table, note the text formatting preserved as well as cell alignment:
Option Explicit
Sub foo()
Dim ppt As PowerPoint.Application
Dim pres As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim tbl As PowerPoint.Shape
Dim unionRange As Range
Dim ar As Range, c As Long, i As Long
Set unionRange = Union([A1:B2], [D1:D2], [F1:F2])
Set ppt = CreateObject("PowerPoint.Application")
ppt.Visible = True
Set pres = ppt.ActivePresentation
Set sld = pres.Slides(1)
' Create initial table with only 1 column
With unionRange
Set tbl = sld.Shapes.AddTable(.Rows.Count, 1)
End With
For Each ar In unionRange.Areas()
For c = 1 To ar.Columns.Count
i = i + 1
With tbl.Table
' Add columns as you iterate the columns in your unionRange
If .Columns.Count < i Then .Columns.Add
.Columns(i).Cells.Borders(ppBorderBottom).Transparency = 1
.Columns(i).Cells.Borders(ppBorderTop).Transparency = 1
.Columns(i).Select
ar.Columns(c).Copy '// Copy the column from Excel
ppt.CommandBars.ExecuteMso ("Paste") '// Paste the values to PowerPoint
End With
Next
Next
End Sub
Maybe more efficient to handle the Areas like so:
For Each ar In unionRange.Areas()
c = ar.Columns.Count
Dim tCol
tCol = .Columns.Count
With tbl.Table
' Add columns as you iterate the columns in your unionRange
While .Columns.Count < (tCol + c)
.Columns.Add
Wend
.Columns(tCol).Cells.Borders(ppBorderBottom).Transparency = 1
.Columns(tCol).Cells.Borders(ppBorderTop).Transparency = 1
.Columns(tCol).Select
ar.Copy '// Copy the columns in THIS Area object from Excel
ppt.CommandBars.ExecuteMso ("Paste") '// Paste the values to PowerPoint
End With
Next
But I still think performance on large data set will suffer vs the other answer.
The issue seems to be caused by the pasting of the non-contiguous range into PowerPoint.
I don't know enough PowerPoint VBA to know whether it has some other paste method you could use, but a work-around would be to create a new Excel worksheet containing just the info you want to copy, and then to copy that worksheet to PowerPoint:
'...
Next k
unionVariable.Copy ' all the data added to ShWork
'Create a temporary sheet (the workbook is being closed without saving
'so the temporary worksheet will be "lost" after we finish)
xlWB.Worksheets.Add Before:=xlWB.Worksheets(1)
'Paste the data into the temporary sheet
xlWB.Worksheets(1).Range("A1").PasteSpecial xlPasteValues
'Copy the temporary sheet
xlWB.Worksheets(1).UsedRange.Copy
tryAgain:
ActiveWindow.ViewType = ppViewNormal
'...
Three issues.
This code is running in 4-5 minutes for me with the database that I currently have. Normally it will be a database with 100~ columns. I want to make this faster.
Another issue I have is that I keep getting two different pop-ups:
"File now Available for Editing"
"User is currently editing workbook, would you like to run in read-only mode?"
Very annoying, but nothing I can't live with.
Lastly, I also sometimes get an error on this line:
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse But all I have to do is re-run the program and it'll go away.
I'm looking for any suggestions to make this code run a little faster and smoother, any recommendations are welcome.
Thanks!
Public Sub averageScoreRelay()
' 1. Run from PPT and open an Excel file
' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56,iq_72".
' 3. find those words and numbers in the opened Excel file after splitting and re-formating string.
' 3. Copy column into a new sheets and repeat for all "iq_'s" until sheets 2 has a table.
' 4. Copy table from xl Paste Table into ppt
' 5. Do this for every slide
'Timer start
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim pptSlide As Slide
Dim Shpe As Shape
Dim pptText As String
Dim pptPres As Object
Dim iq_Array As Variant
Dim arrayLoop As Integer
Dim i As Integer
Dim myShape As Object
Dim colNumb As Integer
Dim size As Integer
Dim k As Integer
Dim lRows As Long
Dim lCols As Long
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
'xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("file.xlsx", True, False, , , , True, Notify:=False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
xlApp.DisplayAlerts = False
With xlWB.Worksheets("Sheet1")
colNumb = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'Create a new blank Sheet in excel, should be "Sheet2"
xlWB.Worksheets.Add After:=xlWB.ActiveSheet
'Make pptPres the ppt active
Set pptPres = PowerPoint.ActivePresentation
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
pptSlide.Select
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
k = 1
'Identify if there is text frame
If Shpe.HasTextFrame Then
'Identify if there's text in text frame
If Shpe.TextFrame.HasText Then
'Set pptText as the Text in the box, then make it lowercase and trim Spaces and Enters
pptText = Shpe.TextFrame.TextRange
pptText = LCase(Replace(pptText, " ", vbNullString))
pptText = Replace(Replace(Replace(pptText, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)
'Identify if within text there is "iq_"
If InStr(1, pptText, "iq_") > 0 Then
'set iq_Array as an array of the split iq's
iq_Array = Split(pptText, ",")
'Find size of the array
size = UBound(iq_Array) - LBound(iq_Array)
'loop for each iq_ in the array'
For arrayLoop = 0 To size
'Statement that will take iq_'s in the form "iq_9" or "iq_99" or "iq_999"
If iq_Array(arrayLoop) Like "iq_#" Or iq_Array(arrayLoop) Like "iq_##" Or iq_Array(arrayLoop) Like "iq_###" Then
'loops for checking each column
For i = 1 To colNumb
'Copies the first column (role column) for every slide that needs it
If i = 1 And arrayLoop = 0 Then
'copy column
xlWB.Worksheets("Sheet1").Columns(1).Copy
'paste column in Sheet2 which was newly created
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(1)
'If this is not the role column, then check to see if the iq_'s match from ppt to xl
ElseIf xlWB.Worksheets("Sheet1").Cells(1, i) = iq_Array(arrayLoop) And i <> 1 Then
'Serves to paste in the next column of Sheet2 so that we end up with a table
k = k + 1
'same as above
xlWB.Worksheets("Sheet1").Columns(i).Copy
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(k)
'Go to next array
GoTo Line2
End If
Next i
'Same as above, just this one is for iq_'s with form "iq_45,46,47" instead of "iq_45,iq_46,iq_47"
ElseIf (iq_Array(0) Like "iq_#" Or iq_Array(0) Like "iq_##" Or iq_Array(0) Like "iq_###") And (IsNumeric(iq_Array(arrayLoop)) And Len(iq_Array(arrayLoop)) <= 3) Then
For i = 1 To colNumb
If i = 1 And arrayLoop = 0 Then
xlWB.Worksheets("Sheet1").Columns(1).Copy
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(1)
ElseIf xlWB.Worksheets("Sheet1").Cells(1, i) = ("iq_" & iq_Array(arrayLoop)) And i <> 1 Then 'if iq in ppt = iq in xl and if not the first cell then execute
k = k + 1
xlWB.Worksheets("Sheet1").Columns(i).Copy
xlWB.Worksheets("Sheet2").Paste Destination:=xlWB.Worksheets("Sheet2").Columns(k)
GoTo Line2
End If
Next i
End If
Line2:
Next arrayLoop
End If
End If
End If
Next Shpe
'calculate last row and last column on sheet2. aka. find Table size
With xlWB.Worksheets("Sheet2")
lRows = .Cells(.Rows.Count, 1).End(xlUp).Row
lCols = .Cells(1, .Columns.Count).End(xlToLeft).Column
'If only one column then go to next slide
If lRows = .Cells(1, 1).End(xlUp).Row And lCols = .Cells(1, 1).End(xlToLeft).Column Then
GoTo Line1
End If
'Copy table
.Range(.Cells(1, 1), .Cells(lRows, lCols)).Copy
End With
'Paste Table into ppt
pptSlide.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse
'Recently pasted shape is the last shape on slide, so it will be the same as count of shapes on slide
Set myShape = pptSlide.Shapes(pptSlide.Shapes.Count)
'Set position:
myShape.Left = -200
myShape.Top = 200
'Clear Sheet2 for next slide
xlWB.Worksheets("Sheet2").Range("A1:P10").Clear
Line1:
Next pptSlide
xlWB.Worksheets("Sheet2").Delete
xlWB.Close
xlApp.Quit
xlApp.DisplayAlerts = True
'End Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
I am trying to copy a range from Excel into PowerPoint using vba.
Copying and Pasting are no Problem, but i can´t get the text in the created PowerPoint table to be aligned right (and vertical Center).
Here is the part how i copy and paste the range:
Dim myWks As Excel.Worksheet
Dim ppSlide As PowerPoint.Slide
wksData.Range("A2:A5").Copy
ppSlide.Shapes.PasteSpecial
Set MyShape = ppSlide.Shapes(ppSlide.Shapes.Count)
MyShape.Top = x
MyShape.Height = y
MyShape.Width = z
MyShape.Left = m
Now I Need something like MyShape.Align = Right (which of course is not working).
Can someone help me with this?
Thx a lot!
Try the following procedure, it works on my Excel file.
You need to have an open PowerPoint, this sub-routine will scan column A in your Excel file (starting from the second row).
It will create a new slide at the end of the open PowerPoint, and will create a Table with the number of rows it found text in your Excel worksheet column A.
At last it will store each Excel's row data in in the new Table.
Sub Export_to_PPT_Table()
Dim wksData As Excel.Worksheet
Dim PPT As PowerPoint.Application
Dim ppslide As PowerPoint.Slide
Dim ppShape As PowerPoint.Shape
Dim ppTable As PowerPoint.Table
' in brackets add your worksheet name
Set wksData = ActiveWorkbook.Worksheets("Sheet2")
Set PPT = New PowerPoint.Application
PPT.Visible = True
'Add a blank slide at the end of an existing PowerPoint
Set ppslide = PPT.ActivePresentation.Slides.Add(PPT.ActivePresentation.Slides.Count + 1, PowerPoint.PpSlideLayout.ppLayoutBlank)
Dim Excel_numofRows As Integer
ExcelRow = 2
' loop through your excel file in Column A, and check for last row with existing text inside
While wksData.Cells(ExcelRow, 1) <> ""
Excel_numofRows = ExcelRow
ExcelRow = ExcelRow + 1
Wend
' create a new Table in the new slide created
' in brackets is where you play with your table's properties
Set ppShape = ppslide.Shapes.AddTable(Excel_numofRows, 1, 100, 100, PPT.ActivePresentation.PageSetup.SlideWidth - 300, 150)
Set ppTable = ppShape.Table
ExcelRow = 2
While wksData.Cells(ExcelRow, 1) <> ""
With ppTable
.Cell(ExcelRow - 1, 1).Shape.TextFrame.TextRange.Text = wksData.Cells(ExcelRow, 1)
.Cell(ExcelRow - 1, 1).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = msoTextEffectAlignmentRight
.Cell(ExcelRow - 1, 1).Shape.TextFrame.VerticalAnchor = msoAnchorMiddle
End With
ExcelRow = ExcelRow + 1
Wend
End Sub
Ok, here is what I am looking for (Im new, so be gentle):
Copy and paste (default format) from excel to powerpoint (from just the one sheet)
I can only fit so many rows in ppt - so after a slide fills, I want ppt to create a new slide
Same title for each slide is fine!
I only need columns B:K copied over
That's it, however I am stuck :( I know the below code is NOT the best way to write this and it contains errors in which I am sure will be easy to spot. I cannot find how to do this anywhere on the net.
This is what I have so far:
Sub ExcelRangeToPowerPoint()
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim i 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 open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
For i = 1 To 6
'need to set focus to slde 1
PowerPointApp.ActiveWindow.View.GotoSlide (1)
'Deletes Title
'mySlide.Shapes.Title.Delete
'builds new title
mySlide.Shapes.AddShape Type:=msoShapeRectangle, left:=9, Top:=6, Width:=702, Height:=30
mySlide.Shapes(mySlide.Shapes.Count).Line.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Size = 20
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Text = "Current Full Initiative Details – Branded Book as of " & Date
mySlide.Shapes(mySlide.Shapes.Count).Name = "I am TITLE"
mySlide.Shapes(mySlide.Shapes.Count).Line.ForeColor.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).Line.Weight = 1
mySlide.Shapes(mySlide.Shapes.Count).Fill.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).Fill.ForeColor.RGB = RGB(255, 255, 255)
'Copy Range from Excel
Set rng = ActiveWorkbook.Worksheets("RAW").Range("B1:K23")
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
PowerPointApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShapeRange.left = 10
myShapeRange.Top = 42
myShapeRange.Height = 492
myShapeRange.Width = 702
ActiveWorkbook.Sheets("RAW").Rows("2:23").Delete
Call myPresentation.Slides.Add(1, PpSlideLayout.ppLayoutTitleOnly)
'Clear The Clipboard
Application.CutCopyMode = False
Next i
End Sub
As requested in comments, here is the code I use to copy a slide from a master PPT template to the report PPT.
There is some extraneous code in there to provide status updates on the form we use to drive the process, as well as a debugging flag that I can toggle on/off at run time - these can both be removed.
This will serve as a starting point to finding the proper solution for your situation, and is not a complete answer to the question as asked.
'I've chosen to declare these globally, though it's probably not the best way:
Dim PPTObj As PowerPoint.Application
Dim PPTMaster As PowerPoint.Presentation
Dim PPTClinic As PowerPoint.Presentation
Private Sub InsertPPT(ByVal SlideName As String, ByVal StatusText As String)
Dim Shp As PowerPoint.Shape
Dim Top As Single
Dim Left As Single
Dim Height As Single
Dim width As Single
PPTMaster.Slides(SlideName).Copy
PPTClinic.Slides.Paste
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT"
With PPTClinic.Slides(PPTClinic.Slides.count)
If Debugging Then
.Select
End If
.Design = PPTMaster.Slides(SlideName).Design 'this ensures we get all the right formatting - only seems to be necessary 1 time, but we'll just do it on all
.ColorScheme = PPTMaster.Slides(SlideName).ColorScheme
.FollowMasterBackground = PPTMaster.Slides(SlideName).FollowMasterBackground
For Each Shp In .Shapes 'loop through all the shapes on the slide
If Debugging Then
' .Select
Shp.Select
End If
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT-" & Shp.Name
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
ReLinkShape Shp, TempVars!NewXLName
'need to store off top, left, width, height
Top = Shp.Top
Left = Shp.Left
Height = Shp.Height
width = Shp.width
Shp.LinkFormat.Update 'and force the link to refresh
MySleep 2, "S" 'hopefully, the 2 second pause will allow everything to update properly before moving on.
'then reset them here - they seem to change shape when I update them
Shp.LockAspectRatio = msoFalse
Shp.Top = Top
Shp.Left = Left
Shp.width = width
Shp.Height = Height
ElseIf Shp.Name = "SlideName" And Not Debugging Then 'if it's the "SlideName" tag
Shp.Delete 'delete it (unless we're debugging)
End If
Next
End With
Form_Master.ProcessStatus.Value = StatusText
End Sub
Private Sub ReLinkShape(ByRef Shp As PowerPoint.Shape, ByVal NewDestination As String)
Dim Link() As String
Dim link2() As String
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
Link = Split(Shp.LinkFormat.SourceFullName, "!") 'update the link to point to the new clinic spreadsheet instead of the master
If InStr(1, Link(2), "]") > 0 Then
link2 = Split(Link(2), "]")
Link(2) = "[" & TempVars!ClinicName & ".xlsx]" & link2(1)
End If
Shp.LinkFormat.SourceFullName = NewDestination & "!" & Link(1) & "!" & Link(2)
End If
End Sub
Public Sub MySleep(ByRef Unit As Double, ByRef UOM As String)
Dim Pause As Date
Pause = DateAdd(UOM, Unit, Now())
While Now < Pause
DoEvents
Wend
End Sub