I am trying to edit a table in a slide, and I am using this code but it takes a lot of time to complete.
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 = 30
End With
Next
Next
Maybe this code can help you. It will change format in each table of active presentation. You just have to update Font Name and Font Size.
Sub format()
Dim s As Slide
Dim oSh As Shape
Dim oTbl As Table
Dim lRow As Long
Dim lCol As Long
For Each s In ActivePresentation.Slides
For Each oSh In s.Shapes
If oSh.HasTable Then
Set oTbl = oSh.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 = "Batang"
.Font.Size = 16
End With
Next
Next
End If
Next
Next s
End Sub
Related
I am trying to add shapes to the slides between sections (with the section number as text in the shape) but I know so far only how to find those with that layout name. I think I should setup a counter somewhere but I have not found a way how.
Ideally I would count the sections and then pass the value later to other parts of the macro to be developed.
Sub Navigator()
Dim oSlide As Slide
Dim oSlideNavigator As Slide
Dim oShapeNavigator As Shape
Dim Section_N As Integer
For Each oSlide In ActivePresentation.Slides
If oSlide.CustomLayout.Name = "Section" Then
Set oShapeNavigator = oSlide.Shapes.AddTable(2, 2, Left:=10, Top:=10, Width:=200, Height:=2)
oShapeNavigator.Fill.ForeColor.RGB = RGB(255, 128, 128)
End If
Next
End Sub
I Set the counter for each slide with Layout Name "Section", then sent the value to the table to be added in those different from those found. So a simple Else did the trick.
Sub NavigatorX()
'Dim SectionXArr() As Long
Dim oSlide As Slide
Dim SectionX As Slide
Dim SectionXArr As SlideRange ' was ReDim
Dim oShapeNavigator As Shape
Dim NavSlide As Slide
Dim nCounter As Long
'Dim NavSlides
Dim iRow As Integer
Dim iColumn As Integer
For Each oSlide In ActivePresentation.Slides
If oSlide.CustomLayout.Name = "Section" Then
nCounter = nCounter + 1
ElseIf nCounter > 0 Then
Set oShapeNavigator = oSlide.Shapes.AddTable(1, 1, Left:=10, Top:=10, Width:=200, Height:=2)
oShapeNavigator.Fill.ForeColor.RGB = RGB(255, 128, 128)
With oShapeNavigator.Table
For iRow = 1 To .Rows.Count
For iColumn = 1 To .Columns.Count
With .Cell(iRow, iColumn).Shape.TextFrame.TextRange
.Text = "Section " & nCounter
With .Font
.Name = "Bahnschrift SemiBold Condensed (Headings)"
.Size = "14"
End With
End With
Next iColumn
Next iRow
End With
End If
Next oSlide
End Sub
I am trying to prompt every paragraph after every image in an active document. For some reason, the prompt pops up empty.
Sub Example1()
Dim intCount As Integer
Dim i As Integer
Dim strCaption As String
'loop through inline shapes
For i = 1 To ActiveDocument.InlineShapes.Count
'check if the current shape is an picture
If ActiveDocument.InlineShapes.Item(i).Type = wdInlineShapePicture Then
strCaption = Selection.Paragraphs(1).Range
MsgBox strCaption
End If
Next i
End Sub
This code might work, depending upon how your InlineShapes are positioned. The code presumes that each picture is in its own paragraph and then picks out the next.
Sub Example1()
Dim i As Integer
Dim strCaption As String
Dim Rng As Range
With ActiveDocument.InlineShapes
'loop through inline shapes
For i = 1 To .Count
With .Item(i)
'check if the current shape is a picture
If .Type = wdInlineShapePicture Then
Set Rng = .Range.Paragraphs(1).Range
With Rng
Do
.Collapse wdCollapseEnd
.MoveEnd wdParagraph
Loop While Len(Trim(.Text)) = 1 And _
.End < .Document.Content.End
strCaption = Rng.Text
End With
MsgBox strCaption
End If
End With
Next i
End With
End Sub
If the text you're after is in the same paragraph as the inlineshape you could use code like:
Sub Demo()
Dim iSHp As InlineShape, Rng As Range
For Each iSHp In ActiveDocument.InlineShapes
Set Rng = iSHp.Range.Paragraphs(1).Range
With Rng
.Start = iSHp.Range.End
MsgBox .Text
End With
Next
End Sub
If the text you're after is in the next paragraph after the inlineshape you could use code like:
Sub Demo()
Dim iSHp As InlineShape, Rng As Range
For Each iSHp In ActiveDocument.InlineShapes
Set Rng = iSHp.Range.Paragraphs(1).Range
With Rng
.Collapse wdCollapseEnd
.MoveEnd wdParagraph, 1
MsgBox .Text
End With
Next
End Sub
I have a specific excel workbook which has tables in different worksheets in different range.I want tables should be automatically copied from all the worksheet of my excel workbook and should be pasted in different slides of my existing ppt template.
I have created a code but giving error on range which I want to copy:
Sub newpp()
Dim pptapp As PowerPoint.Application
Dim pres As PowerPoint.Presentation
Dim preslide As PowerPoint.Slide
Dim shapepp As PowerPoint.Shape
Dim exappli As Excel.Application
Dim exworkb As Workbook
Dim xlwksht As Worksheet
Dim rng As Range
Dim myshape As Object
Dim mychart As ChartObject
Dim lastrow1 As Long
Dim lastcolumn1 As Long
Dim slidecount As Long
'Open powerpoint application
Set exappli = New Excel.Application
exappli.Visible = True
'activate powerpoint application
Set pptapp = New PowerPoint.Application
pptapp.Visible = True
pptapp.Activate
'open the excel you wish to use
Set exworkb = exappli.Workbooks.Open("C:\Users\ap\Desktop\Macro\Reference Sheet.xlsm")
'open the presentation you wish to use
Set pres = pptapp.Presentations.Open("C:\Users\ap\Desktop\Macro\new template.pptx")
'Add title to the first slide
With pres.Slides(1)
If Not .Shapes.HasTitle Then
Set shapepp = .Shapes.AddTitle
Else: Set shapepp = .Shapes.Title
End If
With shapepp
.TextFrame.TextRange.Text = "Gulf+ Market Segment Analysis Report" & vbNewLine & "P5 Week 04 FY17"
.TextFrame.TextRange.Font.Name = "Arial Black"
.TextFrame.TextRange.Font.Size = 24
.TextEffect.FontBold = msoTrue
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
End With
End With
'set the range
lastrow1 = exworkb.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
lastcolumn1 = exworkb.ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
For Each xlwksht In exworkb.Worksheets
xlwksht.Select Application.Wait(Now + TimeValue("0.00:1"))
**'getting error in this line-------**
exworkb.ActiveSheet.Range(Cells(1, 1), Cells(lastrow1, lastcolumn1)).CopyPicture appearance:=xlScreen, Format:=xlPicture
slidecount = pres.Slides.Count
Set preslide = pres.Slides.Add(slidecount + 1, 12)
preslide.Select
preslide.Shapes.Paste.Select
pptapp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, msoTrue
pptapp.ActiveWindow.Selection.ShapeRange.Top = 65
pptapp.ActiveWindow.Selection.ShapeRange.Left = 72
pptapp.ActiveWindow.Selection.ShapeRange.Width = 700
Next xlwksht
End Sub
Replace your For Each xlwksht In exworkb.Worksheets loop with the modified loop below.
I made the following modifications to your code (so it will work):
Instead of Selecting the worksheet and then use ActiveSheet, use xlwksht, I've added the With xlwksht.
You need to search for the last row and column for each worksheet, so I've moved it inside the With statement.
There is no need to Select the slide every time in order to paste.
Some other modifications...
Modified For loop Code
For Each xlwksht In exworkb.Worksheets
With xlwksht
lastrow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
lastcolumn1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
' set the range
.Range(.Cells(1, 1), .Cells(lastrow1, lastcolumn1)).CopyPicture appearance:=xlScreen, Format:=xlPicture
Set preslide = pres.Slides.Add(pres.Slides.Count + 1, 12) ' <-- set the Slide
preslide.Shapes.Paste
With preslide.Shapes(preslide.Shapes.Count) '<-- modify the pasted shape properties
.Top = 65
.Left = 72
' etc...
End With
End With
Next xlwksht
I want a macro that loops through all the slides and change the text in a table to black. When I try the code below, I get the error message: Method 'Table' of 'Shape' failed.
This is my code:
Sub TableAllBlack()
Dim lRaw As Integer
Dim lCol As Integer
Dim oTbl As Table
Dim osld As Slide
Dim oShp As Shape
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
Set oTbl = oSh.Table
With oTbl
For lRow = 1 To .Rows.Count
For lCol = 1 To .Columns.Count
With .Cell(lRow, lCol).Shape
If .HasTextFrame Then
If .TextFrame.HasText Then
TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
End If
End If
End With
Next
Next
End With
Next
Next
End With
End Sub
Not every shape has a Table associated with it. Just add the statement If oSh.HasTable Then... And it should work
This If statement should be placed to encapsulate all of the Table calls, so place it directly before the Set oTbl = oSh.Table line
I am trying to edit a table in a slide, and I am using this code. Can someone please tell me why it isn't working? If instead of s.Shapes.Table I have s.Shapes.Range for example it works fine.
Sub format()
Dim s As Slide
For Each s In ActivePresentation.Slides
With s.Shapes.Table
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Size = 30
End With
Next s
End Sub
Like so instead:
Sub format()
Dim s As Slide
Dim oSh As Shape
Dim oTbl As Table
Dim lRow As Long
Dim lCol As Long
For Each s In ActivePresentation.Slides
' If you choose Debug | Compile, this next line fails
' There's no such property as .Table
' With s.Shapes.Table
For Each oSh In s.Shapes
If oSh.HasTable Then
Set oTbl = oSh.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 = 30
End With
Next
Next
End If
Next ' Shape
Next s
End Sub