[ad_1]
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
[ad_2]