SORU = Hücreye eklediğim görselleri hücrenin ortasına hizalamak

[Fatihckck]

Herkese iyi forumlar;

Hücrelerde bulunan görsellerin hücrenin ortasına hizalanmasını istiyorum bunun için bir makro var elimde ancak bu makro hücrenin sol üstüne sabitliyor.
Bu atacağım makro benim işime yarıyor tek sorun hücrenin sol üstüne sabitlemesi bunu ortaya sabitleyecek şekilde revize etmem gerekiyor yardımcı olur musunuz?
Teşekkürler şimdiden.

Public Sub Fit_All_Selected_Pictures()

Dim pic As Picture
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single

Select Case TypeName(Selection)

Case "DrawingObjects"

For Each pic In Selection
PicWtoHRatio = pic.Width / pic.Height
CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With pic
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With pic
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With pic
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Next

Case "Picture"

Set pic = Selection
PicWtoHRatio = pic.Width / pic.Height
CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With pic
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With pic
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With pic
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With

Case Else

MsgBox "Select 1 or multiple pictures before running this macro."

End Select

End Sub

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Public Sub Fit_All_Selected_Pictures()
    Dim pic As Picture
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    
    Select Case TypeName(Selection)
    
    Case "DrawingObjects"
    
        For Each pic In Selection
            PicWtoHRatio = pic.Width / pic.Height
            CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
            Select Case PicWtoHRatio / CellWtoHRatio
                Case Is > 1
                    With pic
                        .Width = .TopLeftCell.Width
                        .Height = .Width / PicWtoHRatio
                    End With
                Case Else
                    With pic
                        .Height = .TopLeftCell.RowHeight
                        .Width = .Height * PicWtoHRatio
                    End With
            End Select
            With pic
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
            End With
        Next
    
    Case "Picture"
    
        Set pic = Selection
        PicWtoHRatio = pic.Width / pic.Height
        CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
        Select Case PicWtoHRatio / CellWtoHRatio
            Case Is > 1
                With pic
                    .Width = .TopLeftCell.Width
                    .Height = .Width / PicWtoHRatio
                End With
            Case Else
                With pic
                    .Height = .TopLeftCell.RowHeight
                    .Width = .Height * PicWtoHRatio
                End With
        End Select
        With pic
            .Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
            .Left = .TopLeftCell.Left + (.TopLeftCell.Width - .Width) / 2
        End With
    
    Case Else
        MsgBox "Select 1 or multiple pictures before running this macro."
    End Select
End Sub

 

[Fatihckck]

Deneyiniz.

Option Explicit

Public Sub Fit_All_Selected_Pictures()
    Dim pic As Picture
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
  
    Select Case TypeName(Selection)
  
    Case "DrawingObjects"
  
        For Each pic In Selection
            PicWtoHRatio = pic.Width / pic.Height
            CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
            Select Case PicWtoHRatio / CellWtoHRatio
                Case Is > 1
                    With pic
                        .Width = .TopLeftCell.Width
                        .Height = .Width / PicWtoHRatio
                    End With
                Case Else
                    With pic
                        .Height = .TopLeftCell.RowHeight
                        .Width = .Height * PicWtoHRatio
                    End With
            End Select
            With pic
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
            End With
        Next
  
    Case "Picture"
  
        Set pic = Selection
        PicWtoHRatio = pic.Width / pic.Height
        CellWtoHRatio = pic.TopLeftCell.Width / pic.TopLeftCell.RowHeight
        Select Case PicWtoHRatio / CellWtoHRatio
            Case Is > 1
                With pic
                    .Width = .TopLeftCell.Width
                    .Height = .Width / PicWtoHRatio
                End With
            Case Else
                With pic
                    .Height = .TopLeftCell.RowHeight
                    .Width = .Height * PicWtoHRatio
                End With
        End Select
        With pic
            .Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
            .Left = .TopLeftCell.Left + (.TopLeftCell.Width - .Width) / 2
        End With
  
    Case Else
        MsgBox "Select 1 or multiple pictures before running this macro."
    End Select
End Sub

Selamlar bu sefer istediğim gibi ortaya geldi ancak ortalayıp hücrenin tepesine geldi.
Benim istediğim hem yatay hemde dikey olarak hücreyi ortalaması.
Şuanda sadece yatay olarak ortalandı dikey olarak en tepede. Ayrıca 2 den fazla resim seçince uygulama yapmıyor.

Yardımcı olabilirseniz sevinirim teşekkürler şimdiden