I have pasted textboxes over charts.
I'm trying to change the font size within that textbox for all charts.
This is a picture of what I mean
Sub shapeFont()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
With shp.ShapeRange.TextFrame2.TextRange.Font
.Size = 30
End With
Next shp
End Sub
These textboxes seems to be embedded into ChartObjects. So you have to loop your ChartObjects instead. Then loop over its Shapes collection and only when you encounter a proper TextBox you should change it's font. Embedded textboxes can be inserted into a chart by selecting a chart and inserting a shape. From then, these shapes move with the chart.
For example:
Sub FindTextBoxes1()
Dim c As ChartObject
Dim s As Shape
For Each c In ActiveSheet.ChartObjects
For Each s In c.Chart.Shapes
If s.Type = msoTextBox Then
s.TextFrame2.TextRange.Font.Size = 30
End If
Next s
Next c
End Sub
Specify a Workbook and Worksheet variable for pinpointing better where you want this macro to operate (instead of an ugly ActiveSheet)
Inspiration from here
Whereas embedded textboxes are great to distinguish shapes you do want to change from the ones you don't want to change, you also don't need to actually select your textboxes first to be able to change your Font.Size in case you want to iterate over all non-embedded textboxes. Simply refer to the Characters within the TextRange. For example:
Sub FindTextBoxes2()
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Type = msoTextBox Then
s.TextFrame2.TextRange.Characters.Font.Size = 30
End If
Next
End Sub
VBA is a strange language if you actually select it it is able to do it..
Sub shapeFont()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Select
With Selection.ShapeRange.TextFrame2.TextRange.Font
.Size = 30
End With
Next shp
End Sub
If chart object is present and you have separate textboxes this works:
Sub shapeFont()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Select
Debug.Print (shp.Type)
If shp.Type = msoTextBox Then
With Selection.ShapeRange.TextFrame2.TextRange.Font
.Size = 50
End With
End If
Next shp
End Sub
If you want to update the boxes on the chart the code provided by https://stackoverflow.com/users/9758194/jvdv will work
Related
Apologies another noob question. I have been tasked with writing a document within excel, the front cover has a lot of images on it and i have grouped these images together. As there is a risk that the user could move this group. I want to set it so each time that sheet is selected it moves back to its original location. I have looked over the web and i can't seem to find anything for a group of images.
I have tried this and it doesnt work at all. :(
Private Sub Worksheet_Activate()
Dim PicGroup As GroupShapes
With Range("A1")
PicGroup.Name = "HeaderGrp"
PicGroup.Visible = True
PicGroup.Top = .Top
PicGroup.Left = .Left
End With
End Sub
So my group of images I have called HeaderGrp I have put this on Activate Worksheet in VBA and i want this to always move or fix to cells A1.
I would also love this to fit to the page width and length if anyone knows how to do that.
Snapshot of what i would like: -
1) on sheet selection, image group moves to the correct location.
2) image group auto adjusts to page width and height.
Thank you in advance,
This works for me. Pictures appear to be treated as a type of Shape.
Private Sub Worksheet_Activate()
Dim p As Shape
With activesheet
Set p = .Shapes("Pics") 'name
p.Top = .Range("a1").Top
p.Left = .Range("a1").Left
End With
End Sub
This piece of code should get your grouped images:
Option Explicit
Private Sub Worksheet_Activate()
Dim shp As Shape
Dim PicGroup As GroupShapes
'loop through all your shapes
For Each shp In Me.Shapes
'if the shape is grouped then
'set your PicGroup variable
'and exit the loop
If shp.Type = msoGroup Then
Set PicGroup = shp.GroupItems
Exit For
End If
Next shp
With Range("A1")
PicGroup.Name = "HeaderGrp"
PicGroup.Visible = True
PicGroup.Top = .Top
PicGroup.Left = .Left
End With
End Sub
I'm trying to make a favourite button, but the stage I'm on is trying to make the button have no fill and upon click have it show a fill. I have also set up a button to insert the star. Code below:
Sub favourite_btn()
Dim star_shp As Shape
Dim clLeft As Double
Dim clTop As Double
Dim clWidth As Double
Dim clHeight As Double
Set cl = Range("A1")
With star_shp
clLeft = cl.Left
clTop = cl.Top
clWidth = 50
clHeight = 50
End With
Set star_shp = ActiveSheet.Shapes.AddShape(msoShape5pointStar, clLeft, clTop, clWidth, clHeight)
With star_shp
.Line.Visible = msoTrue
'.Fill.Visible = msoFalse
.Fill.ForeColor.RGB = 16777215
End With
End Sub
Sub star_fill()
Set ws3 = Sheets("Sheet1")
Dim shp As Shape
Set shp = ActiveSheet.Shapes("5-Point Star 7")
Dim test As String
Debug.Print shp.Fill.ForeColor.RGB
If shp.Fill.ForeColor.RGB = 16777215 Then 'if it is transparent
shp.Fill.ForeColor.RGB = 65535 'make it yellow
test = ws3.Shapes(Application.Caller).TopLeftCell.Offset(0, 1).Value
MsgBox test
Else
shp.Fill.ForeColor.RGB = 16777215 'otherwise back to transparent
End If
End Sub
and I getting an error when I click on the star (which triggers the star_fill macro "the index into the specified collection is out of bounds" and it highlights the line "Set shp = ActiveSheet.Shapes(star_shp)" in the star_Fill sub. I thought it was because I hadn't set the star_shp variable as a public variable but I did that and it still throws this error.
Any ideas? Would appreciate any help! Thanks
EDIT: Updated my code to reflect the changes as suggested in the comments below. Currently I'm trying to not refer to the Star shape by it's specific name and instead refer to it by it's variable as defined in the first subroutine. So my question is around how to make a variable a global variable so a different subroutine can refer to it
Updated code - toggle between yellow and transparent fill:
Sub star_fill()
Dim shp As Shape
Set shp = ActiveSheet.Shapes("5-Point Star 4")
Debug.Print shp.Fill.ForeColor.RGB
If shp.Fill.ForeColor.RGB = 16777215 Then 'if it is transparent
shp.Fill.ForeColor.RGB = 65535 'make it yellow
Else
shp.Fill.ForeColor.RGB = 16777215 'otherwise back to transparent
End If
End Sub
Update #2:
Public variable will only work if you specify it outside of your Sub routine (the variable value always lives and dies within a given routine, if embedded within the routine). So you would need to do do the following:
Public star_shp as Shape
Sub favourite_btn()
...
However, Public variable approach is not error-proof because it could also lose its reference to the shape (for example, closing and opening the file).
An alternative would be to have a routine to create the shape (like your favourite_btn sub) and a completely separate routine to dictate the shapes' behavior. The example below will work for any shape created by your routine and even if your routine is used to create multiple (different) shapes.
Note the use of:
.OnAction = "star_fill" which assigns your star_fill subroutine to a created shape.
Application.Caller which is used to bind user's selected shape to the subroutine star_fill. Thanks to this line we are no longer in need of creating a Public Variable star_shp.
Sub favourite_btn()
Dim star_shp As Shape
Dim clLeft As Double
Dim clTop As Double
Dim clWidth As Double
Dim clHeight As Double
Dim cl As Range
Set cl = Range("A1")
Set star_shp = ActiveSheet.Shapes.AddShape(msoShape5pointStar, cl.Left, cl.Top, 50, 50)
With star_shp
.Line.Visible = msoTrue
'.Fill.Visible = msoFalse
.Fill.ForeColor.RGB = 16777215
.OnAction = "star_fill"
End With
End Sub
Sub star_fill()
Dim star_shp As Shape
On Error Resume Next
Set star_shp = ActiveSheet.Shapes(Application.Caller)
On Error GoTo 0
If Not star_shp Is Nothing Then
If star_shp.Fill.ForeColor.RGB = 16777215 Then 'if it is transparent
star_shp.Fill.ForeColor.RGB = 65535 'make it yellow
Else
star_shp.Fill.ForeColor.RGB = 16777215 'otherwise back to transparent
End If
End If
End Sub
ActiveSheet.shapes accepts a number as input, and finds the nth shape. You already have your shape (star_shp), so there's no need to try to get it again!
If you don't already have it, however, you'll need to find it by iterating through all shapes in the active sheet looking for star_shp. I recommend tagging it somehow with a persistent identifier (naming it, perhaps?) and looking for that, but make sure you test what happens when the user copies it.
Dim shp As Shape
For Each shp In ActiveSheet.shapes
If shp.name = "sparklesthethird" Then
Msgbox("found it")
Exit For
Endif
Next
I have an excel that has 1 column with picture in each cell, that picture determines something but i would like to change it to 1 instead. There is only 1 picture, and to my exact, the column is J;Name =PO history/release documentation . Can someone help me to do it with VBA Thank you!
Public Sub Replace_Picture()
Const Replace_Text = "OK"
Dim shp as Shape
For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = shp.BottomRightCell.Address Then
shp.TopLeftCell.Value = Replace_Text
shp.Delete
End If
Next
Set shp = Nothing
End Sub
I tried the above code but its not working and const replace_text is in red.
I just want to change those cells with the picture to "1", while those blanks will be leave it to be.
I guess you want to delete the PO history shapes from SAP.
you may have a try by below VBA code.
Another way is you may 'Copy+Paste' data from SAP directly instead of 'Export to Excel'
Sub Replace_Shapes()
Dim Shp As Shape
Dim Shp_Address
For Each Shp In ActiveSheet.Shapes
If Shp.Type = msoPicture Then
'Identify the address of Shape by TopLeft
Shp_Address = Shp.TopLeftCell.Address
Range(Shp_Address) = 1
Shp.Delete
End If Next
End Sub
This is what i try to do. When i click on one button, the autoshape above is copied in the A8:F12 rectangle.
The code for the 1st button(recorded macro):
Sub addTextbox1()
Range("A2:C3").Select
Range("C2").Activate
Selection.Copy
Range("B9").Select
ActiveSheet.Paste
End Sub
My problem is i want to make a button which can erase the autoshape in the A8:F12 range. I found this which delete all autoshapes in the worksheet:
Sub DeleteShapes()
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
Shp.Delete
Next Shp
End Sub
or delete an autoshape by its name (don't work in my case, new autoshapes are generated so i don't know their name)
I know it's fast to click on the shape and press 'delete' but by curiosity i wanted to know if it's possible to do it in VBA
One way below is to test whether the top left cell of the shape lies in your deletion range:
Sub DeleteShapes()
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
If Not Application.Intersect(Shp.TopLeftCell, ActiveSheet.Range("A8:F12")) Is Nothing Then Shp.Delete
Next Shp
End Sub
I am trying to resize the text box size using VBA. To do that I change the rectangle number in the VBA every time which is not serving the purpose of VBA.
I need to resize the selected text box based on value in other cells.
Sub ResizeTextBox()
Dim shp As Shape
Set shp = ActiveSheet.Shapes("Rectangle 39")
shp.Height = Application.CentimetersToPoints(Range("Y5").Value)
shp.Width = Application.CentimetersToPoints(Range("Y6").Value)
End Sub
How do I resize the selected text box based on value in cell Y5 and Y6?
You can do something like this:
Sub ResizeTextBox()
Dim shp As Shape
'check a range is not selected
If TypeName(Selection) <> "Range" Then
With Selection
.Height = Application.CentimetersToPoints(Range("Y5").Value)
.Width = Application.CentimetersToPoints(Range("Y6").Value)
End With
Else
MsgBox "First select a a shape for resizing"
End If
End Sub