No error but no output

Dear Friends,
In this macro I want to resize picture in same size. The macro is not giving any error but also not giving required output. Please solve my problem. The code is as follows:

Sub ResizePicing()
    Dim pic As Object, N As String, ws As Worksheet, R As Range, T As Single
     Set ws = ActiveSheet: ws.Range("g:g").ColumnWidth = 15.43: T = 10
    
    For Each pic In ws.Shapes
    If pic.Type = msoPicture Then
        If Abs(pic.Left - Range("g1").Left) < T Then
                    N = pic.Name
        If InStr(1, N, "Butt") Then GoTo GetNext
            pic.LockAspectRatio = msoFalse
            pic.Width = Application.CentimetersToPoints(1.85)
            pic.Height = Application.CentimetersToPoints(2.38)
        
For Each R In Range("g1:g" & Range("B" & Rows.Count).End(xlUp).Row)
 
    If Abs(pic.Top - R.Top) < T And Abs(pic.Left - R.Left) < T Then
    pic.Left = R.Left: pic.Top = R.Top: R.RowHeight = pic.Height
        Exit For: End If: Next: End If: End If
GetNext:    Next pic
End Sub

Thanking you in anticipation.

Mukesh

Mukesh

I am here for helping people and recently for take care to apply the rules of the forum.

So I make an effort-last one-for helping you and not punishing you. I'll put code tags in your post. Next time, you have to do yourself or else i'll block your thread.

I hope someone will be able to help you.

Good luck.

Hi, Mukesh,

maybe give this macro a run:

Sub ResizePictures()
Dim pic As Shape
Dim ws As Worksheet
Dim sngT As Single

Set ws = ActiveSheet
ws.Range("g:g").ColumnWidth = 15.43
sngT = 10

For Each pic In ws.Shapes
  If pic.Type = msoPicture Then
    With pic
      If Abs(.Left - Range("g1").Left) < sngT Then
        If InStr(1, .Name, "Butt") = 0 Then
          .LockAspectRatio = msoFalse
          .Width = Application.CentimetersToPoints(1.85)
          .Height = Application.CentimetersToPoints(2.38)
          .Left = .TopLeftCell.Left
          .Top = .TopLeftCell.Top
          Rows(.TopLeftCell.Row).RowHeight = .Height
        End If
      End If
    End With
  End If
Next pic
        
End Sub

And maybe resize the pictures and give the rows a different RowHeight before running the code.

Ciao,
Holger

Hi, Mukesh ,

ActiveSheet will rely on the sheet which is on top in the Application - no matter how that sheet is called or what it´s CodeName is.

Originally Posted by TO in opening post

The macro is not giving any error but also not giving required output.

How should anybody know that you´re talking about your "real" workbook, not the one you attached as sample?

Originally Posted by TO in Post #7

...both macros are running without error and giving required output

Ciao,
Holger

Did you see the saggestion in post#4?

Hi, Mukesh,

when I run the code I get the very same result that you have noticed: no action is taken. Reason for that is that msoPicture is not recognised. If I alter the xlConstant msoPicture to 13 and run the code I get the resize to go:

Sub ResizePictures()
Dim pic As Shape
Dim ws As Worksheet
Dim sngT As Single

Set ws = ActiveSheet
ws.Range("g:g").ColumnWidth = 15.43
sngT = 10

For Each pic In ws.Shapes
  If pic.Type = 13 Then
    With pic
      If Abs(.Left - Range("g1").Left) < sngT Then
        If InStr(1, .Name, "Butt") = 0 Then
          .LockAspectRatio = msoFalse
          .Width = Application.CentimetersToPoints(1.85)
          .Height = Application.CentimetersToPoints(2.38)
          .Left = .TopLeftCell.Left
          .Top = .TopLeftCell.Top
          Rows(.TopLeftCell.Row).RowHeight = .Height
        End If
      End If
    End With
  End If
Next pic
        
End Sub

Ciao,
Holger

Hi, Mujesh,

as far as I know there is no command to center a picture in a cell so we need to calculate the width for the cell minus the width of the picture and the divide by 2 and offset that value from the left border of the cell.

New code:

Sub ResizePictures_2()
Dim pic As Shape
Dim ws As Worksheet
Dim sngT As Single

Set ws = ActiveSheet
ws.Range("G:G").ColumnWidth = 15.43
sngT = 10

For Each pic In ws.Shapes
  If pic.Type = 13 Then
    With pic
      If Abs(.Left - Range("g1").Left) < sngT Then
        If InStr(1, .Name, "Butt") = 0 Then
          .LockAspectRatio = msoFalse
          .Width = Application.CentimetersToPoints(1.85)
          .Height = Application.CentimetersToPoints(2.38)
          .Left = .TopLeftCell.Left + (.TopLeftCell.Offset(0, 1).Left - .TopLeftCell.Left - .Width) / 2
          .Top = .TopLeftCell.Top
          Rows(.TopLeftCell.Row).RowHeight = .Height
        End If
      End If
    End With
  End If
Next pic

MsgBox "Finished Resize of Pictures", vbInformation, "Resize done"
        
End Sub

msoPicture is part of the msoType Collection. All these values all have a Constant as Name as well as a Long as Enumeration, and the numeric value for msoPicture is 13. You might look that up either in the Object Browser (it should be in the MSDN as well). Still I can´t explain why msoPicture doesn´t work when 13 will.

HTH,
Holger