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
Related
I'm trying to make a code to resize a shape to a defined size after inserting. I have successfully made it work but the problem is, whenever I insert a new one then run the code, the other shapes keep moving out from their initial location.
The shape I'm inserting is from a sign pad add-in, my output is shown
It supposed to be inside each cell and stay in it.
I have tried adding object position to the code "Don't move or size with cell" using the code : .Placement = xlFreeFloating; but still keeps moving.
My Code is:
Option Explicit
Public Sub ResizePicture()
Dim x As Integer
For x = 1 To 35
On Error GoTo endProc
ActiveSheet.Shapes("SigPlus" & x).Height = 32.5984251969
ActiveSheet.Shapes("SigPlus" & x).Width = 113.3858267717
ActiveSheet.Shapes("SigPlus" & x).IncrementTop 4.5651968504
On Error GoTo endProc
Next x
endProc:
Exit Sub
End Sub
Thanks in Advance
Thanks for your suggestion FunThomas, I manage to make it work now based on that code, my code is:
Option Explicit
Public Sub ResizePicture()
Dim sh As Shape, ws2 As Worksheet
Dim Cel As Range
Dim Rng As Range
Set ws2 = Worksheets("Rev.0")
Set Rng = Selection
For Each Cel In Rng
With Cel
Set sh = ws2.Shapes(ws2.Shapes.Count) 'get last shape, i.e. pasted picture
If .Height / sh.Height < .Width / sh.Width Then
sh.ScaleHeight .Height / sh.Height, msoFalse
Else
sh.ScaleWidth .Width / sh.Width, msoFalse
End If
End With
Next Cel
End Sub
I'm trying to use VBA in Excel to convert a bunch of pictures in a column (one per cell) to a pop up comment image instead so that the sheet is more easily readable.
I can find the image I need by iterating through the shapes, and I can set this as an object; but I can't seem to use that onject to populate the comment field. It seems to be looking for a true file path instead.
I don't particularly want to have to save each image and then reload it, seems kind of pointless.
For Each Pic In ActiveSheet.Shapes
If Pic.TopLeftCell.Address = ActiveCell.Address Then
If Pic.Type = msoPicture Then
Pic.Select
Application.ActiveCell.AddComment.Shape.Fill.UserPicture **(ActiveSheet.Shapes(Pic.name))** 'if I use a path here its okay
'SelectPictureAtActiveCell = name
Exit For
End If
End If
Next
any thoughts?
CJ
I think you want to show one image if you select a specific cell then
See
Making shapes invisible/visible in excel through VBA
with
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Macro1
End Sub
You can make images hide and show using
ActiveSheet.Shapes("ImageName").Visible = False or True
for example when you click on cell A1 first image is hidden else all images are visible
Sub Macro1()
Dim shp As Shape
If ActiveCell.Address = "$A$1" Then
For Each shp In ActiveSheet.Shapes
ActiveSheet.Shapes(1).Visible = False
' or you can use image name as
'ActiveSheet.Shapes("ImageName").Visible = False
'shp.Visible = False
Next
Else
For Each shp In ActiveSheet.Shapes
shp.Visible = True
Next
End If
End Sub
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
I have an excel workbook with two shapes on Sheet1 like below
My Requirement is when the user is navigating towards right side of sheet i.e. Towards headers24, header25 and so on ,I want the two shapes on the sheet to move towards the right side with the user.
Can someone Please suggests any ideas for this.
Thanks
Try this.. yep, its easy..
Place this code in the worksheet module where the shapes exist.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ActiveSheet.Shapes(1)
.Left = ActiveWindow.VisibleRange(2, 2).Left
.Top = ActiveWindow.VisibleRange(2, 2).Top
End With
End Sub
The coordinate (2, 2) is where you want the shape to be fixed at as you scroll along with the keyboard.
But, it would be annoying to work without the scroll bar on a huge worksheet. so alternatively I think you can use refresh ontime, place this code in a Module
Private eTime
Sub ScreenRefresh()
With ThisWorkbook.Worksheets("Sheet1").Shapes(1)
.Left = ThisWorkbook.Windows(1).VisibleRange(2, 2).Left
.Top = ThisWorkbook.Windows(1).VisibleRange(2, 2).Top
End With
End Sub
Sub StartTimedRefresh()
Call ScreenRefresh
eTime = Now + TimeValue("00:00:01")
Application.OnTime eTime, "StartTimedRefresh"
End Sub
Sub StopTimer()
Application.OnTime eTime, "StartTimedRefresh", , False
End Sub
And the following code in Sheet1 (where the shapes are in)
Private Sub Worksheet_Activate()
Call StartTimedRefresh
End Sub
Private Sub Worksheet_Deactivate()
Call StopTimer
End Sub
First create the shape:
Sub Creator()
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddShape(1, 100, 10, 60, 60)
shp.TextFrame.Characters.Text = "I will follow"
shp.Name = "MyButton"
End Sub
Then in the worksheet code area:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sh As Shape, r As Range
Set sh = ActiveSheet.Shapes("MyButton")
Set r = ActiveCell
sh.Top = r.Offset(-1, -2).Top
sh.Left = r.Offset(-1, -2).Left
End Sub
If you move the active cell back and forth, the box will move with it.
Note:
This is only demo code. You still need to:
add protection to prevent trying to move the Shape "off-screen"
setting the proper offsets from ActiveCell based on the size of the Shape
Here is the macro which is in the Sheet1 module:
Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("F1")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub
In the work book this is what it looks like:
How do I gain access to Me.Pictures? We'd like to add pictures and delete some of the existing pictures.
Try running this which just uses the third line in your existing code
Private Sub MakeAllPicsVisible()
Me.Pictures.Visible = True
End Sub
Me refers to the worksheet object the code is in. And each picture appears to be named with the items in the list
To change the picture name, enter a new name via the Name Box (left of Formula bar).