Sayfalar arası resim çağırma

Katılım
7 Temmuz 2020
Mesajlar
37
Excel Vers. ve Dili
Office 2019 Pro Türkçe 64bit
Altın Üyelik Bitiş Tarihi
10-07-2021
Merhabalar;

Sayfa 1 de tıkladığım hücreye göre (Aynı sütundaki) resim getirmesini istiyorum. Mevcut durumda elimde bir kod var ancak bu kod klasörden getiriyor ama benim istediğim bu değil. Bütün resimleri başka bir sayfaya koysam oradan kritere göre çağırma şansım var mı?

Kod:
'''''Modül içerisine yazılacak kod'''''''''''''''''''''''''''''''''''''''''''''
Global yol As String
Sub resim_degistir()
    On Error Resume Next
 strPic = "Resim 2"
    Set shp = ActiveSheet.Shapes(strPic)
    With shp
        t = .Top
        l = .Left
        h = .Height
        w = .Width
    End With
    If yol = "" Then Exit Sub
    ActiveSheet.Shapes(strPic).Delete
    Set shp = ActiveSheet.Shapes.AddPicture(yol, msoFalse, msoTrue, l, t, w, h)
    shp.Name = strPic
End Sub

''''Sayfa içerisine yazılacak kod'''
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Dim satir As Long
If Not Intersect(Target, Range("A1:A60000")) Is Nothing Then
    satir = Target.Row
    yol = Range("B" & satir).Value
    resim_degistir
End If
End Sub
 
Katılım
7 Temmuz 2020
Mesajlar
37
Excel Vers. ve Dili
Office 2019 Pro Türkçe 64bit
Altın Üyelik Bitiş Tarihi
10-07-2021
Ambalaj sayfasındaki Malzeme adlarına tıkladığımda ilgili hücrenin resmi gelmesini istiyorum. Ama her resim için farklı pencere gelmeyecek tek pencerede gösterecek hangisini tıklarsam o resim gelsin. Üstteki kod ile bunu yapabiliyorum ancak onda resimleri klasörden çekiyor benim istediğim bunu resimlerin olduğu sayfadan çeksin. Bu koda revize yapıp istediğim şeyi yapabilir miyim? https://we.tl/t-eDeT2IdACW
 
Katılım
7 Temmuz 2020
Mesajlar
37
Excel Vers. ve Dili
Office 2019 Pro Türkçe 64bit
Altın Üyelik Bitiş Tarihi
10-07-2021
Kod:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:A1000")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target <> "" Then
        Dim Resim, adress, ResimAdi
        On Error Resume Next
        For Each Resim In ActiveSheet.Shapes
            adress = Resim.TopLeftCell.Row
            If Target.Row = adress Then
                Resim.Delete
                Exit For
            End If
    
        Next
        For Each Resim In Sheets("Resim").Shapes
            adress = Resim.TopLeftCell.Column
            If adress = 2 Then
                ResimAdi = Sheets("Resim").Cells(Resim.TopLeftCell.Row, 1).Value
                If ResimAdi = Target Then
                    Resim.Copy
                    ActiveSheet.Paste Destination:=Cells(Target.Row, 2)
                    With Cells(Target.Row, 2)
                        Selection.ShapeRange.LockAspectRatio = msoFalse
                        Selection.Height = .MergeArea.Height - 4
                        Selection.Width = .MergeArea.Width - 4
                        Selection.Top = .Top + 2
                        Selection.Left = .Left + 2
                        Selection.Placement = xlMoveAndSize
                    End With
                    Target.Select
                    Exit Sub
                End If
            End If
        Next
    End If

End Sub
@EmrExcel16 hocamın paylaştığı bu kodu buldum ancak kendi excel dosyama uygulayamadım. bu konuda yardımcı olabilir misiniz?
 

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Sayfa2de resimler var.sayfa2de resmim yanındaki sarı hücreye tıklayınız.
Örnek dosya ektedir.:cool: Ad tanımlaması ve makro kullanılarak yapılmışdır.

RESİM DOSYASI TIKLAYINIZ.
 

Ekli dosyalar

Katılım
7 Temmuz 2020
Mesajlar
37
Excel Vers. ve Dili
Office 2019 Pro Türkçe 64bit
Altın Üyelik Bitiş Tarihi
10-07-2021
Şimdi link ekledim.
Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Range("C1").Value = Target.Row - 1
End Sub
Hocam bu kodda C1 i Resimler sayfasındaki C1 e nasıl yazdırırım. Mazur görün VBA kodlamada çok acemiyim yeni başladım.
 

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Range("C1").Value = Target.Row - 1
End Sub
Hocam bu kodda C1 i Resimler sayfasındaki C1 e nasıl yazdırırım. Mazur görün VBA kodlamada çok acemiyim yeni başladım.
bu kodları resimler sayfasının modülüne yapıştırınız.
 
Katılım
7 Temmuz 2020
Mesajlar
37
Excel Vers. ve Dili
Office 2019 Pro Türkçe 64bit
Altın Üyelik Bitiş Tarihi
10-07-2021
bu kodları resimler sayfasının modülüne yapıştırınız.
Ama hocam benim benim seçilecek olacak olan hücrem Resimler sayfasında değil ben ambalaj sayfasında B sütununda herhangi bir hücreye tıkladığımda o hücreye karşılık gelen resim gelsin istiyorum.
 

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Ama hocam benim benim seçilecek olacak olan hücrem Resimler sayfasında değil ben ambalaj sayfasında B sütununda herhangi bir hücreye tıkladığımda o hücreye karşılık gelen resim gelsin istiyorum.
Bu böyle uzar gider.
Küçük bir örnek dosya ekleyip yollarsanız bakarım.:cool:
 
Katılım
7 Temmuz 2020
Mesajlar
37
Excel Vers. ve Dili
Office 2019 Pro Türkçe 64bit
Altın Üyelik Bitiş Tarihi
10-07-2021
yeni link hocam. Ambalaj sayfasındaki sağdaki boşluğa gelsin istiyorum resim @Orion1
 
Son düzenleme:

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Oda dosya yükleme istiyor.
Aşağıdaki linke ekleyin.
DOSYA YÜKLE
 

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,254
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Listboxtan seçim yaparak resimler sipariş sayfasına gönderiliyor.
 
Son düzenleme:
Üst