VBA to centre range of images in cells

[darb79]

I need to resize images that come from a filepath to 90% of size of cell they are being placed over then centre the image in the cell. Here is my VBA:

Sub AddPictures()
Dim myPic As Picture
Dim wkSheet As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim rowCount As Long
Dim rowCount2 As Long


Set wkSheet = Sheets(1) ' -- Change to your sheet


'-- The usual way of finding used row count for specific column
rowCount2 = wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp).Row


If rowCount2 <> 0 Then
Set myRng = wkSheet.Range("A2", wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp))


For Each myCell In myRng.Cells
If Trim(myCell.Value) = "" Then
MsgBox "No file path"
ElseIf Dir(CStr(myCell.Value)) = "" Then
MsgBox myCell.Value & " Doesn't exist!"
Else
ActiveSheet.Shapes.AddPicture _
Filename:=myCell.Value, LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=myCell.Offset(ColumnOffset:=1).Left, Top:=myCell.Top, _
Width:=myCell.Width, Height:=myCell.Height
End If
Next myCell


Else
MsgBox "There is no file paths in your column"
End If

End Sub

 

[Hui]

Enjoy

Sub AddPictures()
Dim myPic As Picture
Dim wkSheet As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim rowCount As Long
Dim rowCount2 As Long
Dim factor As Double

Set wkSheet = Sheets(1) ' -- Change to your sheet
factor = 0.9

'-- The usual way of finding used row count for specific column
rowCount2 = wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp).Row


If rowCount2 <> 0 Then
  Set myRng = wkSheet.Range("A2", wkSheet.Cells(wkSheet.Rows.Count, "A").End(xlUp))
  
  For Each myCell In myRng.Cells
  If Trim(myCell.Value) = "" Then
  MsgBox "No file path"
  ElseIf Dir(CStr(myCell.Value)) = "" Then
  MsgBox myCell.Value & " Doesn't exist!"
  Else
  ActiveSheet.Shapes.AddPicture _
  Filename:=myCell.Value, _
  LinkToFile:=msoFalse, _
  SaveWithDocument:=msoTrue, _
  Left:=myCell.Offset(ColumnOffset:=1).Left + (myCell.Offset(, 1).Width - myCell.Offset(, 1).Width * factor) / 2, _
  Top:=myCell.Top + (myCell.Offset(, 1).Height - myCell.Offset(, 1).Height * factor) / 2, _
  Width:=myCell.Offset(, 1).Width * factor, _
  Height:=myCell.Offset(, 1).Height * factor
  
  End If
  
  Next myCell

Else
  MsgBox "There is no file paths in your column"
End If

End Sub