Hello everyone My name is Maurizio I write to you as: I just can not solve this problem. So: I created my weather forecasts in VBA; And so far so good. Then I created a sort of repechage of the images belonging to the forecasts. Everything happens inside my workbook. Everything seems to work beautifully; Except for a Done. That is that: When the images are positioned within the cell indicated by me. I would like the images to take the size of a particular cell. While in my case the first image completely fills the first cell plus one piece of the second. While the Second Image only partially fills the second cell and so on. For this reason I was just looking for a system to adapt them all to the corresponding cell. You have a vague idea of how all this can be done, Thanks Greetings from A.Maurizio
Hi Maurizio
I am unable to read your file. However base on your description, you can give the attachment a try.
It contains a macro that will fit any images to a cell. you can select a range of cells.
Just make sure that the top-left hand corner of the image is within the cell.
Hope this helps.
Sunny
Hello SunnyKow, I took a look at your program and it's nice; But my Zip File that I inserted in my post and a little more complicated. As: On Sheet 1 where the extraction of the HTML data of the weather forecast occurs, entries of the "Sunny" type are also reported; "Partly Cloudy" etc ...! After that it compares them not a list that is found in Sheet 2. With the VLookup Code; And found the correspondent goes to draw the image that is inside my images folder of the project itself. Only that everything works wonderful and is definitely faster than what I had given to you at first; But that fished the image through his Link. But I'm trying and trying again that also put all my knowledge, but does not want to know to insert the three images only within their cells adapting to them. That's all ! And to think that the code is this:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim rng As Range
Dim shp As Shape
Dim bln As Boolean
Set rng = Me.Range("D1:F1")
If Not Intersect(Target, rng) Is Nothing Then
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value <> "" Then
For Each shp In Me.Shapes
If shp.Top = Target.Offset(11, 0).Top Then
If shp.Left = Target.Offset(11, 0).Left Then
shp.Delete
End If
End If
Next
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "Immagini" & Application.WorksheetFunction.VLookup(Target.Value, [Tabella], 3, 0)).Select
Selection.Top = Target.Offset(11, 0).Top
Selection.Left = Target.Offset(11, 0).Left
With ActiveSheet.Pictures
.ShapeRange.LockAspectRatio = msoFalse
.Width = Target.Offset(11, 0).Width
.Height = Target.Offset(11, 0).Height
End With
Else
For Each shp In Me.Shapes
If shp.Top = Target.Offset(11, 0).Top Then
If shp.Left = Target.Offset(11, 0).Left Then
shp.Delete
End If
End If
Next
End If
End If
Target.Select
Set rng = Nothing
Foglio1.Range("F6").Select
End Sub
Hello and thank you for your help. Sincere greetings as always from A.Maurizio
Do not hold more account than this my request as I solved this problem almost by accident. Now it works wonders Thank you
