Resizing of Column & Rows in Macro

umesh_jalan 1 Posts Friday February 9, 2018Registration date February 9, 2018 Last seen - Feb 9, 2018 at 03:58 AM - Latest reply: TrowaD 2355 Posts Sunday September 12, 2010Registration dateModeratorStatus May 17, 2018 Last seen
- Feb 15, 2018 at 11:40 AM
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
See more 

Your reply

1 reply

TrowaD 2355 Posts Sunday September 12, 2010Registration dateModeratorStatus May 17, 2018 Last seen - Feb 15, 2018 at 11:40 AM
0
Helpful
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
Respond to TrowaD