Soru Öncü Makro Çalıştırmak

[ercanborais]

Selamlar,

Arkadaşlar böyle bir makro var halihazırda. İstediğimiz şey sadece bu makro çalışmadan önce sayfadaki b7:c1000 aralığındaki resimleri temizlesin. Umarım mümkündür.
Çünkü her resimleri getirdiğinde resimleri üst üste yazıyor...

Sub resim_getir()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = Sheets("Res")
Set s2 = Sheets("Proforma")

Set Alan = Range("b7:c1000")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing

For i = 7 To s2.Range("e65536").End(xlUp).Row
If s2.Cells(i, "d") = "" Then Exit For
aranan = s2.Cells(i, "d").Value
Dim Picture As Object
sat1 = i
sat2 = i
sut1 = "B"
sut2 = "C"
Set Adres = Range(Cells(sat1, sut1).Address, Cells(sat2, sut2).Address)

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
satir = Picture.BottomRightCell.Row
bulunan = s1.Cells(satir, 3).Value
If aranan = bulunan Then
s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture
Range("B" & i).Select
ActiveSheet.Paste
Selection.Top = Cells(sat1, "b").Top
Selection.Left = Cells(sat1, "b").Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Range(Cells(sat1, sut1), Cells(sat2, sut2)).Height
Selection.ShapeRange.Width = Range(Cells(sat1, sut1), Cells(sat2, sut2)).Width
End If
End If
Next Picture
Application.CutCopyMode = False
Range("d" & i).Select
Next i
Application.ScreenUpdating = True
End Sub

 

[muygun]

Merhaba;

Sheets("Res") .select
Set Alan = Range("b7:c1000")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
Sheets("Proforma") .select

Koyu yazı ile belirttiğim mevcut kod aralığını yukarıdaki şekilde düzenleyerek deneyin.
İyi çalışmalar.

 

[ercanborais]

Bu şekilde düzenledim, invalid outside procedure dedi ve hata verdi....
Doğru mu eklemişim ? yanlış anladım heralde...

Application.ScreenUpdating = False
On Error Resume Next
Set s1 = Sheets("Res")
Set s2 = Sheets("Proforma")

Sheets("Res").Select
Set Alan = Range("b7:c1000")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
Sheets("Proforma").Select

For i = 7 To s2.Range("e65536").End(xlUp).Row
If s2.Cells(i, "d") = "" Then Exit For
aranan = s2.Cells(i, "d").Value
Dim Picture As Object
sat1 = i
sat2 = i
sut1 = "B"
sut2 = "C"
Set Adres = Range(Cells(sat1, sut1).Address, Cells(sat2, sut2).Address)

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
satir = Picture.BottomRightCell.Row
bulunan = s1.Cells(satir, 3).Value
If aranan = bulunan Then
s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture
Range("B" & i).Select
ActiveSheet.Paste
Selection.Top = Cells(sat1, "b").Top
Selection.Left = Cells(sat1, "b").Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Range(Cells(sat1, sut1), Cells(sat2, sut2)).Height
Selection.ShapeRange.Width = Range(Cells(sat1, sut1), Cells(sat2, sut2)).Width
End If
End If
Next Picture
Application.CutCopyMode = False
Range("d" & i).Select
Next i
Application.ScreenUpdating = True
End Sub

 

[muygun]

Merhaba;
Ekli dosyayı deneyin.
Makroyu istediğiniz sayfadan çalıştırın. Res sayfasındaki resimlerin silindiğini göreceksiniz.
İyi çalışmalar.

Link:

İndir ercanborais resim sil

Dosyayı indir ercanborais resim sil

dosya.co

 

[ercanborais]

Çok teşekkür ederim fakat ben eksik anlattım ...
Tek butona basarak önce sizin yazdığınız makroyu çalıştırmak (b7:c1000 aralığındaki resimleri temizlemek). hemen sonrasında ise resimleri getirmek istiyorum. bu iki makronun birleşmesi mümkün mü ? yoksa iki tane buton koyacağım birine basacaklar sayfadaki resimleri temizleyecekler sonra diğer butona basacaklar resimler ekrana gelecek.

 

[muygun]

Merhaba;
Örnek dosyanız olmadığı için sadece yazarak ifade edeceğim.
Birden çok makroyu arka arkaya çalıştırmak için;
sub hepsi()
call makro1
call makro2
end sub

Şeklinde farklı isimli makroları hepsi() makrosu altında tıpkı bir alt yordama gider gibi çalıştırır ve işlem sonu hepsi() makrosuna dönmesini sağlayabilirsiniz.

 

[ercanborais]

Kardeşim çalışmanın ufak bir kopyasını ekledim.

Proforma sayfasında yukarda resimleri yenie diye bir buton var. oraya 4-5 kere basarsan resimleri hep üst üste bindiriyiro. Buraya basınca önce bu b7:c1000 aralığındaki resimleri temizleyip sonra yeni resimleri çekmesi lazım. Umarım anlatabilmişimdir. Hakkını helal et lütfen... Allah razı olsun...

Deneme.xlsm - 5.6 MB

 

[muygun]

Merhaba;
Resim isimleri örtüşmüyor.
Res sayfasında resimler hücre dışına taşmış vs..
Eki deneyin.
İyi çalışmalar.

Tavsiye: Ticari olarak kullanacağınız bir uygulama için bir zahmet altın üye olun. (böylece birçok örnek uygulamaya ulaşma/inceleme şansınız olur)
Link:

İndir ercanborais sayfadan resim

Dosyayı indir ercanborais sayfadan resim

dosya.co

 

[ercanborais]

Teşekkür ederim. Kendim firmaya yapıp para kazanmıyorum sadece müşterilere yapılan basit bir sipariş formu aslında. Saygılar....