Rapor sayfasına farklı sayfadan gelen bilginin detayını görüntüleme

[besen]

Rapor sayfasında, A kolonundaki hücreyi tıkladığımda, Gerçekleşme sayfasında, L kolonunda eşleşen bilgilerin sayfada ayrı bir pencerede, örnek görüntü sayfasındaki formatta gözükmesini istiyorum.
Örnekte detaylı açıklama var.
Teşekkür ederim.

 

[Muzaffer Ali]

Merhaba.
Dosyanız ekte.

 

[besen]

Teşekkür ederim.
Gerçekleşme sayfasında renkli alanlarda başlıklar var, örnek dosyada onları silmiştim. Görüntü dosyasına başlıklarında gelmesini rica ediyorum.

Emeğinize sağlık.

 

[Muzaffer Ali]

Rapor sayfasında bulunan kodları silin aşağıdakileri kopyalayın.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Bak As Long
    Dim Syf As Worksheet
    Dim Say As Long
    If Intersect(Target, Range("A:A")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    Set Syf = Worksheets("Örnek Görüntü")
    Syf.Range("A2:L" & Syf.Cells(Rows.Count, "L").End(3).Row).ClearContents
    With Worksheets("Gerçekleşme")
        .Range("A1").Copy Syf.Range("A1")
        .Range("E1").Copy Syf.Range("B1")
        .Range("J1:O1").Copy Syf.Range("C1")
        .Range("Q1").Copy Syf.Range("I1")
        .Range("S1").Copy Syf.Range("J1")
        .Range("V1").Copy Syf.Range("K1")
        .Range("Q1").Copy Syf.Range("L1")
        For Bak = 2 To .Cells(Rows.Count, "L").End(3).Row
            If .Cells(Bak, "L") = Target Then
                Say = Syf.Cells(Rows.Count, "A").End(3).Row + 1
                .Range("A" & Bak).Copy Syf.Range("A" & Say)
                .Range("E" & Bak).Copy Syf.Range("B" & Say)
                .Range("J" & Bak & ":O" & Bak).Copy Syf.Range("C" & Say)
                .Range("Q" & Bak).Copy
                Syf.Range("I" & Say).PasteSpecial (xlPasteValues)
                .Range("S" & Bak).Copy Syf.Range("J" & Say)
                .Range("V" & Bak).Copy Syf.Range("K" & Say)
                .Range("Q" & Bak).Copy
                Syf.Range("L" & Say).PasteSpecial (xlPasteValues)
            End If
        Next
    End With
End Sub

 

[besen]

Süper. Çok teşekkür ederim.

 

[besen]

Rapor sayfasında formatla ilgili işlemler yaptığımda örneğin bazı kolonların boyutunu değiştirdiğimde
Bu kodda " If .Cells(Bak, "L") = Target Then" Debug veriyor.

 

[Muzaffer Ali]

En üst satıra şu satırı ekleyin.

If Intersect(Target, Range("A:A")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub

 

[besen]

Size çok zahmet verdim ama bu hatayı verdi.
Ayrıca kopyalama da yapamıyorum.

 

[Muzaffer Ali]

4. mesajdaki kodu düzenledim dener misiniz

 

[besen]

Evet bu kodu yazınca o hatayı verdi zaten.

If Intersect(Target, Range("A:A")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub

 

[Muzaffer Ali]

Kodlarda bir sorun yok.
Dosyanız ekte.

 

[besen]

Evet söylediğiniz kod üst kısımda kalmış, hata ondan kaynaklı. Çok teşekkür ederim.
Selam, sevgi, saygı.

 

[besen]

Merhaba, dosyada bir değişiklik yapmak ihtiyacı oldu. Şöyle ki;
Aynı dosyada birden fazla projeyi takip ediyoruz.
Bu nedenle daha önce sadece A kolonundaki kodlara bakarken şimdi hem A kolonuna ve sayfadaki C1 hücresindeki proje koduna göre listelensin istiyorum
Yardımınız için teşekkür ederim.
Selam, sevgi, saygı.

 

[Muzaffer Ali]

Merhaba.

Kodlar aşağıdaki, gibi olmalı.

Her iki sayfadaki kodları da aşağıdaki kodlarla değiştirin.

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Bak As Long
    Dim Syf As Worksheet
    Dim Say As Long
    If Intersect(Target, Range("A:A")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    Set Syf = Worksheets("Örnek Görüntü")
    Syf.Range("A2:L" & Syf.Cells(Rows.Count, "L").End(3).Row).ClearContents
    With Worksheets("Gerçekleşme")
        .Range("A1").Copy Syf.Range("A1")
        .Range("E1").Copy Syf.Range("B1")
        .Range("J1:O1").Copy Syf.Range("C1")
        .Range("Q1").Copy Syf.Range("I1")
        .Range("S1").Copy Syf.Range("J1")
        .Range("V1").Copy Syf.Range("K1")
        .Range("Q1").Copy Syf.Range("L1")
        For Bak = 2 To .Cells(Rows.Count, "L").End(3).Row
            If .Cells(Bak, "L") = Target And .Cells(Bak, "J") = Range("C1") Then
                Say = Syf.Cells(Rows.Count, "A").End(3).Row + 1
                .Range("A" & Bak).Copy Syf.Range("A" & Say)
                .Range("E" & Bak).Copy Syf.Range("B" & Say)
                .Range("J" & Bak & ":O" & Bak).Copy Syf.Range("C" & Say)
                .Range("Q" & Bak).Copy
                Syf.Range("I" & Say).PasteSpecial (xlPasteValues)
                .Range("S" & Bak).Copy Syf.Range("J" & Say)
                .Range("V" & Bak).Copy Syf.Range("K" & Say)
                .Range("Q" & Bak).Copy
                Syf.Range("L" & Say).PasteSpecial (xlPasteValues)
            End If
        Next
    End With
End Sub

 

[besen]

Harikasınız, müteşekkirim.

 

[besen]

Bir küçük istek daha, işlem yapıldığında sayfa otomatik olarak örnek görüntü sayfasına geçebilir mi?

 

[Muzaffer Ali]

Kodların en sonuna End Sub dan önce şu satırı ekleyin.

worksheets("SayfaAdi").activate

SayfaAdi yerine geçmek istediğiniz sayfa adını yazın.

 

[besen]

Teşekkür ederim.