Resim Al, Farklı Hücrelere

[1Al2Ver]

Merhaba,

"YERLEŞİM_PLANI-1" sayfadaki kod ile, "VERİ_LİSTESİ" sayfasında "b2" hücresindeki isime (düşeyara ile "VERİ_LİSTESİ" sayfasından alınıyor) karşılık gelen resim, "YERLEŞİM_PLANI-1" , "d3" hücresine alınıyor,

Ben, kodun genişletilerek , "VERİ_LİSTESİ" ndeki resimlerin;

"YERLEŞİM_PLANI-1" sayfasındaki diğer hücrelere de alınmasını arzuluyorum,

Örneğin, "YERLEŞİM_PLANI-1" sayfasında ;

"B2" nin karşılığı......"D3" e
"F2" nin karşılığı ....."H3" e
"J2" nin karşılığı......."L3" e
"N2" nin karşılığı......"P3" e
"R2" nin karşılığı......"T3" e
"V2" nin karşılığı......"X3" e
"Z2" nin karşılığı ....."AB2" ye

"B9" un karşılığı......"D10" a
"F9" un karşılığı ....."H10" a
........................
........................
"B16" nın karşılığı.."D17" ye
.......................

şeklinde gelebilecek bir yapı ile, "YERLEŞİM_PLANI-1" sayfasında sütun ve satırların, azalıp, çoğalabilmesi durumunda, kod'da gerekli çıkarmayı yada kod'a ilave yapmayı arzuluyorum.

1'den fazla sayfa oluşturacağım, bu nedenle kod'un, sayfanın koduna yazılmasını rica ederim.

Teşekkür ederim.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Intersect(Target, [b2]) Is Nothing Then Exit Sub
On Error GoTo çıkış
ActiveSheet.DrawingObjects.Delete
Dim ResimYolu As Variant
Dim Resim As Object

ResimYolu = ActiveWorkbook.Path & "\" & Range("b2") & ".jpg"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("d3")

Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width

End With
çıkış:
End Sub

 

[askm]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim ResimYolu As Variant
If Intersect(Target, [B2:AB10000]) Is Nothing Then Exit Sub

On Error GoTo çıkış

Dim Resim As Picture, Alan As Range
    
    Set Alan = Cells(Target.Row + 1, Target.Column + 2)

    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
    Next
       
Set Alan = Nothing
'ActiveSheet.DrawingObjects.Delete


ResimYolu = ActiveWorkbook.Path & "\" & Target.Value & ".jpg"

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Cells(Target.Row + 1, Target.Column + 2)

Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width

End With

çıkış:

End Sub

 

[1Al2Ver]

Sayın askm merhaba,

Çok teşekkür ederim, ellerinize sağlık, sağ olun.

Saygılarımla.

 

[askm]

Rica ederim.

 

[1Al2Ver]

Sayın askm tekrar merhaba,

Aşağıdaki kod'da resmin boyutunu ben belirlemek istiyorum, nasıl bir düzenleme yaparız ?

Teşekkür ederim.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Intersect(Target, [b2]) Is Nothing Then Exit Sub
On Error GoTo çıkış
ActiveSheet.DrawingObjects.Delete
Dim ResimYolu As Variant
Dim Resim As Object

ResimYolu = ActiveWorkbook.Path & "\" & Range("b2") & ".jpg"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("d3")

[COLOR="Red"]Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width[/COLOR]

End With
çıkış:
End Sub

 

[askm]

Resim.Top = 60
Resim.Left = 60
Resim.Height = 60
Resim.Width = 60
şeklinde girebilirsiniz.

 

[1Al2Ver]

Sayın askm merhaba,

Teşekkür ederim.

 

[1Al2Ver]

Merhaba,

5 no.lu mesajdaki kodda ;

ActiveSheet.DrawingObjects.Delete

satırı resmi silerken, sayfadaki 2 adet ToogleButton'u da siliyor,

Bunu yapmaması nasıl sağlanır ?

Teşekkür ederim.

 

[askm]

O bütün resimleri siler. Ben alan ile sınırlama getirmiştim ona.

 

[1Al2Ver]

Sayın askm merhaba,

O bütün resimleri siler. Ben alan ile sınırlama getirmiştim ona.

anladım.

Peki 5 no.lu mesajdaki kod'da bunu aşabilir miyiz ? O kodu başka bir sayfada kullanıyorum çünkü,

Yada başka bir öneriniz olabilir mi ?

Teşekkür ederim.

 

[askm]

Örnek dosyanız mı vardı sanki.

 

[1Al2Ver]

Sayın askm merhaba,

Ekledim,

Teşekkür ederim.

 

[askm]

Ancak aşağıdaki şekilde olabilir.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Intersect(Target, [b2]) Is Nothing Then Exit Sub
On Error GoTo çıkış

Dim Alan As Range
Set Alan = Range("D3")
For Each Resims In ActiveSheet.DrawingObjects
    If Not Intersect(Resims.TopLeftCell, Alan) Is Nothing Then
        Resims.Delete
    End If
Next

'ActiveSheet.DrawingObjects.Delete

Dim ResimYolu As Variant
Dim Resim As Object
    
ResimYolu = ActiveWorkbook.Path & "\" & Range("b2") & ".jpg"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("d3")

Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width

End With
çıkış:
End Sub

 

[1Al2Ver]

Sayın askm merhaba,

İsimler değiştiğinde resimleri silmedi, üst üste getirdi,

Kod'da sadece "b2" leri "B3" ve "d3" leri de "B5" yaptım,

Öncesinde gönderdiğiniz kod ile çalıştım, sonuç değişmedi,

Sanırım benim uygulayacağım dosyada bir sorun var.

Tekrar teşekkür ederim, iyi geceler.

 

[askm]

İsterseniz dosyanızı askmadige34@hotmail.com adresine mail atın bakayım.

 

[1Al2Ver]

Sayın askm, merhaba,

Aynı sayfada ;

[COLOR="Red"]Private Sub Worksheet_Change(ByVal Target As Range)[/COLOR]
If Intersect(Target, [B3, S1, W1]) Is Nothing Then Exit Sub
Call test
End Sub

kodu var, ben kodu pasif yapınca sorun olmuyor,

Kodu, bir düğmeye atayarak manuel çalıştırırsak olacak sanıyorum,

Sub Hesap_Al ()
If Intersect(Target, [B3, S1, W1]) Is Nothing Then Exit Sub
Call test
End Sub

şeklinde denedim ancak hata verdi,

Üstteki kodun çağırdığı test ;

Sub test()

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Set harc = Sheets("HARCAMA_LİSTESİ"): Set s = Sheets("HARCAMA_RAPORU")
If s.Cells(Rows.Count, 5).End(3).Row > 1 Then s.[e4:e50] = ""
harc.Range("A1:H1").AutoFilter Field:=3, Criteria1:=s.[b3].Value
harc.Range("A1:H1").AutoFilter Field:=2, _
    Criteria1:=">=" & CLng(s.[S1]), Operator:=xlAnd, Criteria2:="<=" & CLng(s.[W1])
For sat = 2 To harc.Cells(Rows.Count, 5).End(3).Row
    If harc.Rows(sat & ":" & sat).EntireRow.Hidden = False And _
        WorksheetFunction.CountIf(s.Range("E:E"), harc.Cells(sat, 5)) = 0 Then
        s.Cells(s.Cells(Rows.Count, 5).End(3).Row + 1, 5) = harc.Cells(sat, 5)
    End If
Next: harc.AutoFilterMode = False
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

Teşekkür ederim.

 

[askm]

Dosyanızı mail atarsanız bakalım.

 

[1Al2Ver]

Sayın askm merhaba,

İlginiz ve yardımlarınız için çok teşekkür ederim,

Dosya çok karışık ve uzun olduğu için eklemedim, göndermedim.

Başa döndüm ve aşağıdaki kodu kullandım, mevcut düğmelerden de vaz geçtim,

Tekrar teşekkür ederim.

Saygılarımla.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Intersect(Target, [b3]) Is Nothing Then Exit Sub
On Error GoTo çıkış
ActiveSheet.DrawingObjects.Delete
Dim ResimYolu As Variant
Dim Resim As Object

ResimYolu = ActiveWorkbook.Path & "\" & Range("b3") & ".jpg"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("b5")

Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width

End With
çıkış:
End Sub