Sub Ìàêðîñ1()
  Óäàëèòü_ôèãóðû
    Dim fso As Object, fl As Object, f As Object, r As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    Dim T As Double, L As Double
    Dim sh
     
    Set fl = fso.GetFolder(ThisWorkbook.Path)
    T = Cells(4, 3).Left
    L = Cells(4, 3).Top
    For Each f In fl.Files
        If f.Name Like "*.jpg" Then
            Set sh = ActiveSheet.Shapes.AddPicture(f.Path, False, True, T, L, -1, -1)
            
            r = r + 1: Cells(r, 1) = sh.Height: Cells(r, 2) = sh.Width
            
            sh.Height = Range("4:25").Height
            
            r = r + 1: Cells(r, 1) = sh.Height: Cells(r, 2) = sh.Width
            r = r + 1: Cells(r, 1) = Cells(r - 1, 1) / Cells(r - 2, 1): Cells(r, 2) = Cells(r - 1, 2) / Cells(r - 2, 2)
            
            sh.Left = T
            sh.Top = L
            T = T + sh.Width
        End If
    Next f
End Sub