I have the following code, which sorts some pictures down according to a value in Sheet1. Horizontally the images are aligned in the required columns. But not in the Rows.
I tried to do it with another FOR loop that I called J but doesn't work, it puts the images on top of each other.
How can I align the pictures in a column and a row that I choose?
What am I doing wrong? or what am I missing?
Thank you.
-------------CODE-------------
Sub CommandButton2_Click()
Dim firma_pic As Picture
Dim pic_location As String
Dim identifier_pic As String
'For j = 14 To 23
'Next
'Worksheets("Sheet3").Cells(14, 23).Select
For i = 2 To 11
identifier_pic = Worksheets("Sheet1").Cells(i, 11).Value
pic_location = "C:\Users\User\Downloads\Docs\img\" & Worksheets("Sheet1").Cells(i, 2).Value & ".png"
With Worksheets("Sheet3").Cells(i, 24)
Set firma_pic = ActiveSheet.Pictures.Insert(pic_location)
firma_pic.Top = .Top
firma_pic.Left = .Left
firma_pic.ShapeRange.LockAspectRatio = msoFalse
firma_pic.Placement = xlMoveAndSize
firma_pic.ShapeRange.Width = 70
firma_pic.ShapeRange.Height = 30
End With
Next
Worksheets("Sheet3").Cells(i, 23).Select
End Sub
Width and Height need to consider your cell too. You may resize images and force them to be W=70 and H=30 where the cell begins, but it could lead to images overlapping between columns. I'd suggest you to stick to the same workflow as you did for Top and Left
firma_pic.ShapeRange.Width = .Width
firma_pic.ShapeRange.Height = .Height
Related
I have 12 pictures that I've dragged and dropped into the sheet directly from a windows folder. They are named "1 1.bmp", "1 2.bmp", "1 3.bmp" and so on.
I want to move them but how?
This is the code I'm trying:
Worksheets("R").Shapes("1 1").Top = Worksheets("R").Rows(24).Top
I don't know how reference to them. They are in the same folder as the .xlsm file. I've tried
Worksheets("R").Shapes("1 1.bmp").Top = Worksheets("R").Rows(24).Top
too.
Both examples from another question here on stack overflow.
What is the correct syntax?
/Jens
Here is the code to first insert picture to Excel and then adjust or resize the Picture. Later move the Picture towards down or right:
'Insert the Picture from the path if its not present already
Set myPict = Thisworkbook.sheets(1).Range("A1:B5").Parent.Pictures.Insert(ThisWorkbook.Path & "\" & "mypic.jpg")
'Adjust the Picture location
myPict.Top = .Top
myPict.Width = .Width
myPict.Height = .Height
myPict.Left = .Left
myPict.Placement = xlMoveAndSize
'myPict.LockAspectRatio = msoTriStateMixed
'Change the width of the Picture
myPict.Width = 85
'change the Height of the Picutre
myPict.Height = 85
End With
'Select the Picutre
myPict.Select
'Move down the picture to 3 points. Negative value move up
Selection.ShapeRange.IncrementTop 3
'Move towards right upto 5 points. Negative value moves towards right
Selection.ShapeRange.IncrementLeft 5
Try this code:
Option Explicit
Sub ArrangePictures()
Dim sh As Shape, anchor_cell As Range, v_shift As Long
With Worksheets("R")
Set anchor_cell = .Range("B24") 'left top corner for pictures
v_shift = 0 'vertical shift for next picture
For Each sh In .Shapes 'loop over all the shapes in the sheet
If sh.Type = msoPicture Then 'check if the shape is a picture
sh.Top = anchor_cell.Top + v_shift 'move picture (vertical)
sh.Left = anchor_cell.Left 'move picture (horizontal)
v_shift = v_shift + sh.Height 'add vertical shift for next picture
End If
Next
End With
End Sub
I have a function which searchs through all the textboxes in a file and when it finds the text it automatically scrolls the window to the shape that contains the text.
Is it possible to:
a) scroll to the text, instead of the shape (scroll the page and center it on the search text result)
b) if not possible, then scroll to the middle of the shape (now it's going to the top)
If InStr(LCase(sTemp), LCase(sFind)) <> 0 Then
shp.Select
With shp.Line
.ForeColor.RGB = vbRed
.Weight = 5
End With
sFind2 = LCase(sFind)
sTemp2 = LCase(shp.TextFrame.Characters.Text)
iPos2 = InStr(sTemp2, sFind2)
If iPos2 > 0 Then
With shp.TextFrame.Characters(Start:=iPos2, _
Length:=Len(sFind2)).Font
.Size = 35
End With
End If
shp.Select
ActiveWindow.ScrollRow = shp.TopLeftCell.Row
ActiveWindow.ScrollColumn = shp.TopLeftCell.Column
End If
Useless to say: I am not an expert, sorry for the bad formatting.
a) you cannot scroll to a text. You can just scroll full rows and full columns.
b) you can do that only approximately, because you can just scroll full rows and full columns.
Since shp.TopLeftCell finds the top left cell under the shape, you can try to use the height/width of the shape and cells to find the cell that is approximately in the middle of the shape.
'scroll additional rows
Dim CellHeights As Double
CellHeights = shp.TopLeftCell.Height
Dim iRow As Long
Do While CellHeights < shp.Height / 2
CellHeights = CellHeights + shp.TopLeftCell.Offset(RowOffset:=iRow).Height
iRow = iRow + 1
Loop
ActiveWindow.ScrollRow = shp.TopLeftCell.Offset(RowOffset:=iRow).Row
'scroll additional columns
Dim CellWidths As Double
CellWidths = shp.TopLeftCell.Width
Dim iCol As Long
Do While CellWidths < shp.Width / 2
CellWidths = CellWidths + shp.TopLeftCell.Offset(ColumnOffset:=iCol).Width
iCol = iCol + 1
Loop
ActiveWindow.ScrollColumn = shp.TopLeftCell.Offset(ColumnOffset:=iCol).Column
I'm using a code that inserts a picture (column A) of the corresponding item number located in Column B.
Current positioning of the picture:
However, the pictures that are inserted are located in the top left corner of each cell and I'd like to have them in the center of the cell a little below the cell line (cell size is 54 and picture is 50).
Here's the code that I use:
Sub InsertImageFullName()
On Error Resume Next
Application.ScreenUpdating = False
Dim path$, cl As Range, myPicture As Object
Set Rng = Range("A2:A300")
cell_h = Range("A2").Top - Range("A1").Top
For Each cl In Rng
path = cl.Offset(0, 8).Value
If path Like "*?*" Then
Set myPicture = ActiveSheet.Pictures.Insert(path)
With myPicture
.ShapeRange.LockAspectRatio = msoTrue
.Height = 50
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
End If
Set myPicture = Nothing
Next
End Sub
What needs to be modified to make this work ?
Any help is greatly appreciated
To set the position of the picture you youst need to adjust the top and left position of it.
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
So you just need to add something. So if your cell height is 54 and your picture height is 50 and your picture should be centered the amount you need to add calculates like add = (CellHeight - PictureHeight) / 2 which is (54 - 50) / 2 which is 2 so you need to add 2 to the .Top position:
.Top = Rows(cl.Row).Top + 2 'add 2 to the top position of your picture.
You know image width and height by myPicture.Width and myPicture.Height. And cell width and height by cl.Width and cl.Height
Image top position is Cell top + (Cell top - Image Height) / 2
And image left position is Cell left + (Cell left - Image Width) / 2
So you need to Change your code from
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
To
.Top = cl.Top + (cl.Height - myPicture.Height) / 2
.Left = cl.Left + (cl.Width - myPicture.Width) / 2
End With
Try to use Vertical Alignment and Horizontal Alignment on Range object to align content of a cell properly.
I'm trying to import a picture to excel cell and I'm facing issues with re-sizing.
Steps:
Copy/Paste the picture to the cell
Re-size the picture manually
And also resize the cell to fix on the picture.
Is there any other way to do it instead of manually?
I'm not sure what exactly you meant with re size the picture manually, but might this be working for you?
Sub ResizeCells()
Dim X As Double, Y As Double, Z As Double
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Type = msoPicture Then
For X = s.TopLeftCell.Column To s.BottomRightCell.Column
Y = Y + ActiveSheet.Cells(1, X).ColumnWidth
Next X
For X = s.TopLeftCell.Row To s.BottomRightCell.Row
Z = Z + ActiveSheet.Cells(1, X).RowHeight
Next X
s.TopLeftCell.ColumnWidth = Y
s.TopLeftCell.RowHeight = Z
End If
Next s
End Sub
Note:
Max RowHeight is 409
Max ColumnWidth is 255
This goes the other way.
We will insert a Shape from the Internet.
We will move it to cell B1.
We will resize the Shape (both height and width) to fit in B1First place this link in cell A1:
http://www.dogbreedinfo.com/images26/PugPurebredDogFawnBlackMax8YearsOld1.jpg
Then run:
Sub MAIN()
Call InstallPicture
Call PlaceAndSizeShape
End Sub
Sub InstallPicture()
Dim v As String
v = Cells(1, 1).Value
With ActiveSheet.Pictures
.Insert (v)
End With
End Sub
Sub PlaceAndSizeShape()
Dim s As Shape, B1 As Range, w As Double, h As Double
Set s = ActiveSheet.Shapes(1)
s.Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Set B1 = Range("B1")
s.Top = B1.Top
s.Left = B1.Left
s.Height = B1.Height
s.Width = B1.Width
End Sub
This post is old, but nobody mentioned resizing the picture to match the cell.
Excel is very unreliable when I tired to scale the width using #Andrew's code. Luckily, rCell.Left is in the correct units. You can get the actual column width using:
rCell.Offset(0, 1).Left - rCell.Left
This Code will Resize the Cell to Your Picture
Sub ResizePictureCells()
For Each Picture In ActiveSheet.DrawingObjects
PictureTop = Picture.Top
PictureLeft = Picture.Left
PictureHeight = Picture.Height
PictureWidth = Picture.Width
For N = 2 To 256
If Columns(N).Left > PictureLeft Then
PictureColumn = N - 1
Exit For
End If
Next N
For N = 2 To 65536
If Rows(N).Top > PictureTop Then
PictureRow = N - 1
Exit For
End If
Next N
Rows(PictureRow).RowHeight = PictureHeight
Columns(PictureColumn).ColumnWidth = PictureWidth * (54.29 / 288)
Picture.Top = Cells(PictureRow, PictureColumn).Top
Picture.Left = Cells(PictureRow, PictureColumn).Left
Next Picture
End Sub
Hi I want to add customize data label to my bubble chart. my code is below. at the moment data label refer to XValues. I would like my data label fill with bubble size. would u mind help me how I can customize below code?
I tried to add .DataLabel.Text = "txt" but I received below
error:
Run-time error '438':Object doesn't support this property or method
Public Sub CreateMultiSeriesBubbleChart()
If (Selection.Columns.Count <> 4 Or Selection.Rows.Count < 3) Then
MsgBox "Selection must have 4 columns and at least 2 rows"
Exit Sub
End If
Dim red, green, blue As Integer
Dim bubbleChart As ChartObject
Set bubbleChart = ActiveSheet.ChartObjects.Add(Left:=Selection.Left, Width:=600, Top:=Selection.Top, Height:=400)
bubbleChart.Chart.ChartType = xlBubble
Dim r As Integer
For r = 2 To Selection.Rows.Count
With bubbleChart.Chart.SeriesCollection.NewSeries
.Name = "=" & Selection.Cells(r, 1).Address(External:=True)
.XValues = Selection.Cells(r, 2).Address(External:=True)
.Values = Selection.Cells(r, 3).Address(External:=True)
.BubbleSizes = Selection.Cells(r, 4).Address(External:=True)
.Format.Fill.Solid
.Format.Fill.ForeColor.RGB = RGB(61, 161, 161)
' .DataLabel.Text = "txt"
End With
Next
bubbleChart.Chart.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
bubbleChart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "=" & Selection.Cells(1, 2).Address(External:=True)
bubbleChart.Chart.SetElement (msoElementPrimaryValueAxisTitleRotated)
bubbleChart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Text = "=" & Selection.Cells(1, 3).Address(External:=True)
bubbleChart.Chart.SetElement (msoElementPrimaryCategoryGridLinesMajor)
bubbleChart.Chart.Axes(xlCategory).MinimumScale = 0
End Sub
My input sample:
Label Hour Day count
01-SUNDAY 14 1 1
01-SUNDAY 19 1 1
02-MONDAY 12 2 1
02-MONDAY 13 2 1
02-MONDAY 14 2 2
02-MONDAY 16 2 2
Without using VBA, right click on the bubbles and select Add Data Labels. Then, right click on the data labels and click Format Data Labels. Under Label Options, select Value From Cells and specify the cells containing the labels you'd like to use.
DataLabel.Text is a method for a Point, not the NewSeries
This code:
For r = 2 To Selection.Rows.Count
With bubbleChart.Chart.SeriesCollection.NewSeries
[...]
.DataLabel.Text = "txt"
End With
Next
...attempts to label the series, and fails.
Recognizing this code as being from another famous example of "multi-series Bubble Charts", it is a logical assumption that we only need to handle 1 data point per series, which makes the following code the solution:
For r = 2 To Selection.Rows.Count
With bubbleChart.Chart.SeriesCollection.NewSeries
[...]
.Points(1).HasDataLabel = True
.Points(1).DataLabel.Text = "txt"
End With
Next