2 Resim Getirme

[zerali]

Arkadaşlar bu proğramda yapmak istediğim M3 ve M19 daki isimlere tıkladığımda gelen isimlerle beraber Resim sayfasındaki resimlerin Belgelerim sayfasındaki D10 H10 ve D23 H23 ün olduğu çizgili yere resimlerin gelmesi. Şimdiden Teşekkürler

İndir GÜZEL YAZI xlsm

Dosyayı indir GÜZEL YAZI xlsm

dosya.co

 

[halit3]

Öncelikle kodun çalışması için Resim sayfasındaki resimler hücrelerden taşmasın yani hücrelerin içinde kalsın zarar yok resim küçük olsun
bu kod sayfanızdaki birinci bölüm içindir diğer bölümler için kodu kendinize göre yaparsınız.

Sub veri1()

Set s2 = Sheets("BELGELERİM")
Set s1 = Sheets("Resim")

aranan = s2.Cells(3, 13).Value

sat1 = 10
sat2 = 14

sut1 = 4
sut2 = 5
sut3 = 8
sut4 = 9

Dim say5 As Long

say5 = 0

s2.Cells(1, "k").Select

Set Adres1 = s2.Cells(sat1, sut1)
Set Adres2 = s2.Range(s2.Cells(sat1, sut1).Address, s2.Cells(sat2, sut2))
Set Adres3 = s2.Range(s2.Cells(sat1, sut3).Address, s2.Cells(sat2, sut4))
Set Adres4 = s2.Cells(sat1, sut3)

Dim Picture As Object

For Each Picture In s2.Shapes
If TypeName(s2.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Set yer = s2.Cells(Picture.TopLeftCell.Row, Picture.TopLeftCell.Column)
If yer.Address = Adres1.Address Then
Picture.Delete
End If
If yer.Address = Adres4.Address Then
Picture.Delete
End If
End If
Next Picture

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
satir = Picture.BottomRightCell.Row
bulunan = s1.Cells(satir, 4).Value & " " & s1.Cells(satir, 5).Value
If aranan = bulunan Then

If 2 = Picture.BottomRightCell.Column Then
say5 = say5 = 1
s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture
s2.Paste Destination:=s2.Range("D10")
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Top = Adres2.Top + 3
Selection.ShapeRange.Left = Adres2.Left + 3
Selection.ShapeRange.Height = Adres2.Height - 4
Selection.ShapeRange.Width = Adres2.Width - 4
Application.CutCopyMode = False
s2.Cells(1, "k").Select
'MsgBox 3
GoTo atla

End If

If 1 = Picture.BottomRightCell.Column Then
say5 = say5 = 1
s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture
s2.Paste Destination:=s2.Range("H10")
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Top = Adres3.Top + 3
Selection.ShapeRange.Left = Adres3.Left + 3
Selection.ShapeRange.Height = Adres3.Height - 4
Selection.ShapeRange.Width = Adres3.Width - 4
Application.CutCopyMode = False
s2.Cells(1, "k").Select
End If


If say5 = 2 Then
Exit For
End If
End If
End If
atla:
Next Picture

Range("A2").Select
MsgBox "işlem tamam"
End Sub

 

[zerali]

Halit hocam teşekkür ederim .Kodu ekledim resimleri düzelttim ama çalıştıramadım. Resimler gelmedi.

 

[halit3]

kodları bir modüle eklemeniz gerekiyordu ve komut düğmesiyle çalıştırmalısınız.

 

[zerali]

Çok teşekkürler Halit3 hocam. Emeğinize sağlık