Am trying to hide or move a series of shapes in excel.
I have a range of cells that I want to copy as a picture and basically if the shape isn't 'active' i.e. contains text then I don't want the shapes to be visable in this range of cells. Each shape is linked and if the if/vlookup is true the shape will contain text.
The following is not working - have tried modifying .Visable with .Right i.e. to shift the shapes out of range - but it says object does not support this property or method.
Sub Macro3()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim shp As Shape
Dim tr As TextRange2
Dim grp As Shape
Dim sShape As Shape
Set shp = ws.Shapes("Line Callout 1 2")
Set tr = shp.TextFrame2.TextRange
For Each ws In ThisWorkbook.Worksheets
For Each shp In ws
If shp.Name Like "Line Callout 1" And tr.Characters.Text = "" Then
sShape.Right = 300
Else
sShape.Right = 0
End If
Next shp
Next ws
End Sub
If I specify a named cell I can alter the visability but for over 600 shapes I want to auomate this somehow This works for named shape and named range:
Sub Macro1()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
With ws.Shapes.Range(Array("Line Callout 1 1"))
.Fill.Visible = Range("x")
.Line.Visible = Range("x")
End With
End Sub
Related
I want to select several shapes in a slide and change their colour. I have tried :
Sub psu_off()
Dim shp As Object
Dim myArray() As Variant
Dim myRange As Object
myArray = Array("C1", "R1", "R2")
Set myRange = ActivePresentation.Slides(22).Shapes.Range(myArray)
For Each shp In myRange
shp.Fill.ForeColor.RGB = RGB(255, 155, 244)
Next
End Sub
The code above only change colour to the first elemnt "C1". Looks like is not looping. What is the issue?
I need to extract data from text boxes in a PowerPoint presentation and put them in respective cells in an Excel worksheet.
I have searched but can't find a suitable work-around.
This code is to print the text from slides. I can't understand how to arrange it in Excel cells.
Dim oPApp As Object
Dim oSlide As Object
Dim oShape As Object
Set oPApp = GetObject(, "PowerPoint.Application")
For Each oSlide In oPApp.ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = 1 Or oShape.Type = 14 Then
Debug.Print oShape.TextFrame.TextRange.Text
End If
Next oShape
Next oSlide
Set oPApp = Nothing
Example of slide (Input):
Example of sheet (Output):
Supposing you want it to be done from Excel module (it could be done from PowerPoint Module also), I just adding some codes & suggestions to your code. However it is to be mentioned while looping through Shapes in a PowerPoint Slide It generally comes in order of creation of the shape. So for maintaining proper sequence of the fields, you have to work out some way sort them according to their position (i.e. top, left property or any other criteria according to the presentation). Try
Dim oPApp As Object
Dim oSlide As Object
Dim oShape As Object
Dim Rw, StCol, Col, Sht As Long
Rw = 2 'Starting Row of Target excel data
StCol = 1 'Starting Column of Target excel data
Sht = 3 'Target Worksheet no.
Set oPApp = GetObject(, "PowerPoint.Application")
'It will only work for already opened active presentation
'It can also be suugested that first create a powerpoint object and then open desired preesntation fron the path
For Each oSlide In oPApp.ActivePresentation.Slides
Col = StCol
For Each oShape In oSlide.Shapes
If oShape.Type = 1 Or oShape.Type = 14 Then
' Debug.Print oShape.TextFrame.TextRange.Text
'Next line was added for putting the data into excel sheet
ThisWorkbook.Sheets(Sht).Cells(Rw, Col).Value =
oShape.TextFrame.TextRange.Text
End If
Col = Col + 1
Next oShape
Rw = Rw + 1
Next oSlide
Set oPApp = Nothing
however one word of caution msoTextBox type is 17 and type 14 is msoPlaceholder.
My code isn't working to modify shape visability ... can you help?
Have named a cell [test] and want a line callout shape to appear/ disappear based on a value in a cell. 1 = visable 0= not visable
Sub Macro1()
Dim ws As Worksheet
With ws.Shapes.Range(Array("Line Callout 1 1"))
.Fill.Visible = [test]
.Line.Visible = [test]
End With
End Sub
Try this
Sub Macro1()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
With ws.Shapes.Range(Array("Line Callout 1 1"))
.Fill.Visible = Range("test")
.Line.Visible = Range("test")
End With
End Sub
I have the following VBA code that works to export a range of cells into a jpeg into a specified folder. I would like to have it loop through all worksheets in one workbook.
I need help looping this code through all open workbooks. I believe I will need to:
Dim WS As Worksheet, then set up an If statement, insert the below code, end the if statement, then at the end put a Next WS for it to actually loop through. My problem is, is that I keep getting a 91 error when I try to combine my if statement, For Each WS In ThisWorkbook.Sheets If Not WS.Name = "Sheet2" Then, with my code below.
The following code works in one worksheet at a time.
Sub ExportAsImage()
Dim objPic As Shape
Dim objChart As Chart
Dim i As Integer
Dim intCount As Integer
'copy the range as an image
Call ActiveSheet.Range("A1:F2").CopyPicture(xlScreen, xlPicture)
'remove all previous shapes in the ActiveSheet
intCount = ActiveSheet.Shapes.Count
For i = 1 To intCount
ActiveSheet.Shapes.Item(1).Delete
Next i
'create an empty chart in the ActiveSheet
ActiveSheet.Shapes.AddChart
'select the shape in the ActiveSheet
ActiveSheet.Shapes.Item(1).Select
ActiveSheet.Shapes.Item(1).Width = Range("A1:F2").Width
ActiveSheet.Shapes.Item(1).Height = Range("A1:F2").Height
Set objChart = ActiveChart
'clear the chart
objChart.ChartArea.ClearContents
'paste the range into the chart
objChart.Paste
'save the chart as a JPEG
objChart.Export ("C:\Users\------\Desktop\Test\" & Range("B2").Value & ".jpg")
'remove all shapes in the ActiveSheet
intCount = ActiveSheet.Shapes.Count
For i = 1 To intCount
ActiveSheet.Shapes.Item(1).Delete
Next i
End Sub
Add this to your module:
Sub MAIN()
Dim sh As Worksheet
For Each sh In Sheets
sh.Activate
Call ExportAsImage
Next sh
End Sub
and run it. (there is no need to modify your code)
I have this code but when the VBA copies and pastes the charts on the Excelsheet, the Charts overlap.
Is there a way to arrange them in 1 column without overlapping?
Thank you!
Sub Test1()
Dim cht As Excel.ChartObject
Worksheets("ChartObjects").ChartObjects.Delete
For Each Sheet In ActiveWorkbook.Worksheets
If Sheet.Name <> "ChartObjects" Then
Sheet.Select
For Each cht In Sheet.ChartObjects
cht.Select
cht.Copy
Sheets("ChartObjects").Select
Range("C5").Select
ActiveSheet.Paste
Next
End If
Next Sheet
End Sub
You can use the .Top and .Left properties of the cell, and the .Top and .Height properties of each ChartObject to align each successive chart with the previous chart's bottom:
Sub foo()
Dim cht As ChartObject
Dim newCht As ChartObject
Dim sht As Worksheet
Dim chtSht As Worksheet
Dim top As Double
Dim left As Double
'Define the destination worksheet
Set chtSht = ActiveWorkbook.Worksheets("ChartObjects")
'Define the starting parameter for the charts
With chtSht.Range("C5")
top = .top
left = .left
End With
'Iterate the sheets in the workbook
For Each sht In ActiveWorkbook.Worksheets
'Ignore the chtSheet
If Not sht.Name = chtSht.Name Then
'Iterate the charts in each worksheet
For Each cht In sht.ChartObjects
'Copy the chart
cht.Copy
'Paste it in to the destination sheet
chtSht.Paste
'Get a handle on the chart we just pasted
Set newCht = chtSht.ChartObjects(chtSht.ChartObjects.Count)
'Assign the top location of this chart
newCht.top = top
newCht.left = left
'Add with the height of this chart to determine the "top" for the next chart
top = newCht.top + newCht.Height
Next
End If
Next
End Sub