Allocation of images to a specific cell-CodePudding

Here is the code Ive written for placing images in a sheet

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next

    If Target.Address = "$A$2" Then
        Call schedules
    End If
End Sub

Sub schedules()
    Worksheets("Picture").Activate
    
    Application.ScreenUpdating = False

    Dim myObj
    Dim Foto
    Set myObj = ActiveSheet.DrawingObjects

    For Each Foto In myObj
        If Left(Foto.Name, 7) = "Picture" Then
            Foto.Select
            Foto.Delete
        End If
    Next
    
    Dim CommodityName1 As String, CommodityName2 As String, T1 As String, T2 As String
    Dim i As Integer, j As Integer, k As Integer
        
    l = 0
    j = 0
    
    For i = 2 To 200
        myDir = "C:\Users\User\Desktop\ESTIMATING SHEETS\test\rebar shapes" & "\"
        CommodityName1 = Range("A" & i)
        T1 = ".png"

        On Error GoTo errormessage:
        ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T1, _
          linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=230, Top:=j, Width:=140, Height:=80

errormessage:
        If Err.Number = 1004 Then
            Exit Sub
            MsgBox "File does not exist." & vbCrLf & "Check the name of the rebar!"
            Range("A" & i).Value = ""
            Range("C10").Value = ""
        End If

        Application.ScreenUpdating = True
        i = i   11
        j = j   190
        l = l   1

        If l = 4 Then
            j = j - 20
            Application.ScreenUpdating = True
            l = 0
        End If
    Next i
End Sub

The problem is after the first iteration starts to displace images incorrectly

Ive tried using the below code to counteract it but its no good.

If l = 4 Then
    j = j - 20
    Application.ScreenUpdating = True
    l = 0

So is there a way to place images in an exact cell position? That way I can run the loop and it wont be off centre

CodePudding user response：

You can use Range.Top and Range.Left to get the top left position of a cell. And you can use that to position your shapes.

So if you have a cell eg E5 and you want to position your picture/object to that cell you can do that like

Dim CellToPutTheObject As Range
Set CellToPutTheObject = Range("E5")

With Shapes(1)
    .Top = CellToPutTheObject.Top
    .Left = CellToPutTheObject.Left
End With

So now the top left of the Shape(1) will be the top left of cell E5.

You can also use

.Width = CellToPutTheObject.Width
.Height = CellToPutTheObject.Height

to make the width and height to fit the width and height of the cell.

CodePudding user response：

I Just rewrote it. Found something better

Sub schedulemacro()
Dim k As Integer
Dim data As Worksheet, Picture As Worksheet
Dim i As Integer, j As Integer

Set data = Sheets("Data")
Set Picture = Sheets("Picture")
j = 13

k = WorksheetFunction.CountA(data.Range("b:b"))

 Range("A1:G12").Select
 Selection.copy

For i = 1 To k





Picture.Range("a" & j).Select
 
ActiveSheet.PasteSpecial

j = j   12
Next i

j = 1

For i = 1 To k


    

Picture.Cells(j, 1) = data.Range("A" & i)

j = j   12

Next i


Call GetPic



End Sub
Sub GetPic()
Dim fNameAndPath As String
Dim img As Object
Dim CommodityName1 As String, T1 As String
Dim myDir As String
Dim i As Integer, j As Integer
Worksheets("Picture").Activate
Dim shape As Excel.shape
Dim datarangeb As Range
Dim numberofcells As Integer

Set datarangeb = Sheets("Data").Range("b:b")

numberofcells = WorksheetFunction.CountA(datarangeb)
numberofcells = numberofcells * 12   1

For Each shape In ActiveSheet.Shapes
        shape.Delete
Next


j = 7

For i = 2 To numberofcells

myDir = "C:\Users\User\Desktop\ESTIMATING SHEETS\test\rebar shapes" & "\"
CommodityName1 = Range("a" & i)
T1 = ".png"

fNameAndPath = myDir & CommodityName1 & T1

On Error GoTo errormessage:

    Set img = ActiveSheet.Pictures.Insert(fNameAndPath)
    On Error GoTo errormessage:
    With img
       'Move and Resize Image
       .ShapeRange.LockAspectRatio = msoFalse
       .Left = ActiveSheet.Range("d" & i).Left
       .Top = ActiveSheet.Range("d" & i).Top
       .Width = ActiveSheet.Range("d" & i & ":g" & i).Width
       .Height = ActiveSheet.Range("d" & i & ":g" & j).Height
errormessage:
If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the rebar!"
End If
       
    End With
    


Application.ScreenUpdating = True


i = i   11
 j = j   12
Next i


i = i - 1


End Sub

enter code here