İstenilen satırları ard arda başka sheet te listelemek

[lev_sez]

Merhaba arkadaşlar,

Yapmak istediğimi kısaca anlatayım:

sayfa1 de alt alta yazılmış kısa kodlar bulunmakta. Sarı boyalı bu kodların üzerine çift tıkladığımda sayfa2 de kısa kodun altında listeli olan bilgileri alıp sayfa3 teki listeye yerleştirsin. bu işlemi birden fazla tekrarlamak istiyorum. Yani ben sayf1 de durmadan kısa kodların üzerlerine çift tıklayacağım ve sayfa2 de karşılık gelen listeyi alıp sayfa3 te alt alta yerleştirecek. sayfa3 te bu tıklamalarım sonucu uzun bi liste oluşacak.

Ben bunu yapabilmeyi deniyorum ama mümkünmü bilemiyorum.

Eğer yardımcı olabilecek arkadaşlar var ise işimi çok kolaylaştıracak bu benim.

Şimdiden teşekkür ederim.

 

[lev_sez]

yardımcı olabilecek kimse yok mu_?

 

[halit3]

yardımcı olabilecek kimse yok mu_?

15 dakika geçmiş 2. mesajınızı göndermişsiniz kodlar yazılırken denemek gerekiyor baya uzun zaman alabiliyor

 

[lev_sez]

teşekkürler

 

[lev_sez]

çok teşekkürler elinize sağlık

 

[Orion1]

Dosyanız ektedir.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sat As Long, i As Long, sh As Worksheet, k As Range, deg As Collection
Dim sat2 As Long
If Intersect(Target, Range("C9:C" & Cells(65536, "C").End(xlUp).Row)) Is Nothing Then Exit Sub
Cancel = True
If Target.Value = "" Then Exit Sub
Set deg = New Collection
Set sh = Sheets("Sayfa3")
With Sheets("Sayfa2")
    For i = 9 To Cells(65536, "C").End(xlUp).Row
        If Cells(i, "C").Value <> Target.Value Then deg.Add Cells(i, "C").Value
    Next i
    Set k = .Range("A2:A65536").Find(Target.Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        sat = k.Row
        sat2 = sh.Cells(65536, "A").End(xlUp).Row + 1
        If sat2 < 12 Then sat2 = 12
        Do While .Cells(sat, "A").Value <> ""
            If sat2 >= 655366 Then
                MsgBox "[ Sayfa3'te Satır doldu.Kayıt girilmedi.", vbCritical, "UYARI"
                Exit Sub
            End If
            .Range("A" & sat & ":H" & sat).Copy sh.Range("A" & sat2)
            sat = sat + 1: sat2 = sat2 + 1
            For i = 1 To deg.Count
                If .Cells(sat, "A").Value = deg(i) Then Exit Do
            Next i
        Loop
        MsgBox "[ " & Target.Value & " ] Bilgileri Sayfa3'e aktarıldı." & vbLf & vbLf & _
"www.evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    End If
End With
End Sub

 

[lev_sez]

Evren çok teşekkür ederim eline sağlık.

Son bir sorum.

Ben bu sarı kutucukları çoğaltmak ve çeşitlendirmek istiyorum aynı sutunda aşağıya doğru. ve aynı zamanda sayfa 2 dekileride çoğaltmak istiyorum yani seçenek olarak mesela AHU-2 farklı olarak.. bunları nasıl ekleyebilirim bu senin yapmış olduğun formatın üzerine

 

[Orion1]

Evren çok teşekkür ederim eline sağlık.

Son bir sorum.

Ben bu sarı kutucukları çoğaltmak ve çeşitlendirmek istiyorum aynı sutunda aşağıya doğru. ve aynı zamanda sayfa 2 dekileride çoğaltmak istiyorum yani seçenek olarak mesela AHU-2 farklı olarak.. bunları nasıl ekleyebilirim bu senin yapmış olduğun formatın üzerine

C9 dan aşağıaya istediğiniz kadar çeşit ekleyebilirsiniz.
Dosyayı buna göre güncelledim.Öceki mesajımdan dosyayı indrebilirsiniz.

 

[lev_sez]

çok çok teşekkür ederim benim çok büyük bi zahmetten kurtardın hocam.

 

[Orion1]

çok çok teşekkür ederim benim çok büyük bi zahmetten kurtardın hocam.

Rica ederim.İyi çalışmalar.