Soru Hücreye Eklenen Fotoğrafın "Taşı ve Boyutlandır" Özelliğinin Aktif Olması

likaba

Altın Üye
Katılım
3 Mayıs 2016
Mesajlar
158
Excel Vers. ve Dili
2016 Türkçe
Altın Üyelik Bitiş Tarihi
21-12-2027
Merhabalar,

Değerli üstatların hazırlamış olduğu makro kodunu kendi excel sayfama uyarladım.
İlgili makro; eklediğim fotoğraflar hücre boyutuna göre otamatik olarak boyutlandırılıyor.
Bu makro koduna ilave olarak eklenen fotoğrafın "hücrelerle taşı ve boyutlandır" seçeneğinin aktif olmasını istiyorum.
Sebebi ise sütunda filtreleme yaptığımda ilgili satırda ki fotoğraflarla birlikte satırların gelmesi...

Bu konu hakkında yardımcı olabilir misiniz?

Kod:
Private Sub CommandButton1_Click()

Dosya = Application.GetOpenFilename("All Files (*.*),*.*.")
If Dosya = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If

Set Adres = Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Pictures.Insert(Dosya).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 3
Selection.ShapeRange.Width = Adres.Width - 3
Cells(1, 1).Select

End Sub
225755
 
Katılım
15 Şubat 2021
Mesajlar
52
Excel Vers. ve Dili
Excel 2016/VBA
Altın Üyelik Bitiş Tarihi
17-02-2022
dener misiniz.

Kod:
Private Sub CommandButton1_Click()

Dosya = Application.GetOpenFilename("All Files (*.*),*.*.")
If Dosya = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If

Set Adres = Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Pictures.Insert(Dosya).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 3
Selection.ShapeRange.Width = Adres.Width - 3
Selection.Placement = xlMoveAndSize
Cells(1, 1).Select

End Sub
 

likaba

Altın Üye
Katılım
3 Mayıs 2016
Mesajlar
158
Excel Vers. ve Dili
2016 Türkçe
Altın Üyelik Bitiş Tarihi
21-12-2027
dener misiniz.

Kod:
Private Sub CommandButton1_Click()

Dosya = Application.GetOpenFilename("All Files (*.*),*.*.")
If Dosya = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If

Set Adres = Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Pictures.Insert(Dosya).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 3
Selection.ShapeRange.Width = Adres.Width - 3
Selection.Placement = xlMoveAndSize
Cells(1, 1).Select

End Sub
Çok teşekkür ederim. Tam istediğim gibi oldu
 
Üst