Resizing of Column & Rows in Macro

Closed
Report
Posts
1
Registration date
Friday February 9, 2018
Status
Member
Last seen
February 9, 2018
-
Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
-
Respected CCM team members,

Greetings!!

I am trying to insert images from a folder into excel by matching file names specified in a column, everything is running fine but facing issue of row & column resizing according to image size.

It would be very helpful if anyone can guide to edit the below mentioned macro, so that the column & row gets resized automatic.

Thanks in Advance.

Macro mentioned below..
Private Sub CommandButton1_Click()
Dim pictureNameColumn As String
Dim picturePasteColumn As String

Dim pictureName As String
Dim lastPictureRow As Long
Dim pictureRow As Long
Dim pathForPicture As String

pictureNameColumn = "A"
picturePasteColumn = "B"

pictureRow = 1

On Error GoTo Err_Handler

lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row

Application.ScreenUpdating = False

pathForPicture = "C:\Users\Public\Pictures\Sample Pictures\"

Do While (pictureRow <= lastPictureRow)

pictureName = Cells(pictureRow, "A")

If (pictureName <> vbNullString) Then

If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then

Cells(pictureRow, picturePasteColumn).Select
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select

With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 95#
.ShapeRange.Rotation = 0#
End With

ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then

Cells(pictureRow, picturePasteColumn).Select
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select

With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 95#
.ShapeRange.Rotation = 0#
End With

ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then

Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored

With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 95#
.ShapeRange.Rotation = 0#
End With

Else
'picture name was there, but no such picture
Cells(pictureRow, picturePasteColumn) = "No Picture Found"
End If

Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
Loop

Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub

1 reply

Posts
2829
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 22, 2021
490
Hi Umesh,

All your picture sizes are the same. So you only have to adjust the columnwidth once and for the row height use:
Cells(pictureRow, picturePasteColumn).rowheight= enter numeric value here

Best regards,
Trowa