Klasörden Resim Almada Hücreye ortalama sorunu?

[ozhanturk]

Merhaba arkadaşlar

Aşağıdaki gibi kod lama yaptım. ancak resmi hücreye ortalayamıyorum. Bu konuda bana yardım ederseniz sevinirim...

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b26:b65536]) Is Nothing Then Exit Sub
If Target.Row Mod 2 = 2 Then Exit Sub
On Error Resume Next
For c = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(c).Left = Target.Offset(0, 1).Left _
And ActiveSheet.Shapes(c).Top = Target.Offset(0, 1).Top Then
ActiveSheet.Shapes(c).Delete
End If
Next c
ActiveSheet.Pictures.Insert("c:\Resimler\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 1).Top
Selection.Left = Target.Offset(0, 1).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = (70)
Selection.ShapeRange.Width = (80)
Target.Select
End Sub

 

[halit3]

bunu denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b26:b65536]) Is Nothing Then Exit Sub
If Target.Row Mod 2 = 2 Then Exit Sub
On Error Resume Next
For c = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(c).Left = Target.Offset(0, 1).Left _
And ActiveSheet.Shapes(c).Top = Target.Offset(0, 1).Top Then
ActiveSheet.Shapes(c).Delete
End If
Next c
ActiveSheet.Pictures.Insert("c:\Resimler\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 1).Top
Selection.Left = Target.Offset(0, 1).Left
Selection.Height = Target.Offset(0, 1).Height
Selection.Width = Target.Offset(0, 1).Width
Selection.ShapeRange.LockAspectRatio = msoFalse
Target.Select
End Sub

 

[ozhanturk]

Sayın Halit Bey öncelikle ilginize teşekkür ederim.
Dosyayı ekde ekledim.

Ben bilerek boyut vermiştim resime.
Çünkü kenarlık çizgilerinin üstüne geliyor. Dosyadada göreceksiniz ne demek istediğimi. tam ortaya gelerek kenarlık çizgilerinin üstüne gelmemesini sağlamak amacım.

Görüşmek üzere...

 

[halit3]

böyle denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b26:b65536]) Is Nothing Then Exit Sub
If Target.Row Mod 2 = 2 Then Exit Sub
On Error Resume Next
For c = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(c).Left = Target.Offset(0, 1).Left _
And ActiveSheet.Shapes(c).Top = Target.Offset(0, 1).Top Then
ActiveSheet.Shapes(c).Delete
End If
Next c
ActiveSheet.Pictures.Insert("C:\Resimler\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 1).Top + 2
Selection.Left = Target.Offset(0, 1).Left + 2
Selection.Height = Target.Offset(0, 1).Height - 3
Selection.Width = Target.Offset(0, 1).Width - 3
Selection.ShapeRange.LockAspectRatio = msoFalse
Target.Select
End Sub

 

[ozhanturk]

Sayın Halit Bey

Bilginiz her daim sizinle olsun. Çok teşekkür ederim.
İyiki varsınız.

 

[halit3]

Sayın Halit Bey

Bilginiz her daim sizinle olsun. Çok teşekkür ederim.
İyiki varsınız.

İyi çalışmalar

 

[quantum32]

Merhabalar halit bey,

ekteki dosyayı indirdim. c nin altına resimler klasörü koydum ancak sayfada neyi nereye yazacağımı bulamadım ve çalıştıramadım. yardımcı olabilirmsiniz.
teşekkürler