seçilen hücreyi başka sayfada alt alta sıralama

[samedgunduz]

Merhaba,

Elimdeki personel listesine göre her hafta şoförlere ödeme yapılıyor. Fakat ödeme karışık yapıldığı için benim istediğim olay örnek tabloda eklediğim listede Sayfa 1 de ismini tıkladığım personel Sayfa 2 de tıkladığım sıraya göre aşağıya doğru sıralanmasını istiyorum. Yardımcı olabilir misiniz ?

 

[Ömer]

Merhaba,

Sayfa1 in kod bölümüne ekleyerek deneyiniz. A: D sütunlarındaki herhangi bir hücreye çift tıklarsanız, ilgili satırın B sütunundaki personel kodu uyumlu personeller Sayfa2 de listelenir.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim S1 As Worksheet, c As Range, Adr As String, sat As Long
  
    Set S1 = Sheets("Sayfa2")
  
    If Intersect(Target, Range("A2:D" & Rows.Count)) Is Nothing Then Exit Sub
  
    Application.ScreenUpdating = False
    S1.Range("A2:D" & Rows.Count).ClearContents
  
    sat = 2  
    Set c = [B:B].Find(Cells(Target.Row, "B"), , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            S1.Cells(sat, "A") = sat - 1
            S1.Cells(sat, "B") = Cells(c.Row, "B")
            S1.Cells(sat, "C") = Cells(c.Row, "C")
            S1.Cells(sat, "D") = Cells(c.Row, "D")
            sat = sat + 1
          
            Set c = [B:B].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If

End Sub

 

[samedgunduz]

hocam öncelikle hızlı cevabınız için teşekkürler.
Vermiş olduğunuz kodu uyguladım. Bir sorun var. Tıkladığım personeli sayfa 2 ye atıyor fakat başka personeli tıkladığımda diğeri silinip sadece tıklamış olduğum hücreyi getiriyor. Benim yapmak istediğim tıklama sırama göre her tıkladığım personeli sayfa 2 de alt alta dizsin.

 

[Ömer]

Deneyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim S1 As Worksheet, c As Range, Adr As String, sat As Long
 
    Set S1 = Sheets("Sayfa2")
 
    If Intersect(Target, Range("A2:D" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False

    sat = S1.Cells(Rows.Count, "B").End(xlUp).Row + 1
    Set c = [B:B].Find(Cells(Target.Row, "B"), , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            S1.Cells(sat, "A") = sat - 1
            S1.Cells(sat, "B") = Cells(c.Row, "B")
            S1.Cells(sat, "C") = Cells(c.Row, "C")
            S1.Cells(sat, "D") = Cells(c.Row, "D")
            sat = sat + 1
          
            Set c = [B:B].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If

End Sub

 

[samedgunduz]

çok sağolun Ömer Bey şimdi oldu

son olarak birşey daha isteyebilir miyim tıkladığım personeli sayfa 2 de görmem zor oluyor sürekli arka sayfaya bakmaktansa tıkladığım hücreyi yine sayfa 1 de örneğin G sutunundan başlayarak aşağıya doğru dizebilir miyiz ?

 

[samedgunduz]

birde tıkladığım personel farklı bir renge boyansa

 

[Ömer]

Deneyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim c As Range, Adr As String, sat As Long

    If Intersect(Target, Range("A2:D" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False

    sat = Cells(Rows.Count, "H").End(xlUp).Row + 1
    Set c = [B:B].Find(Cells(Target.Row, "B"), , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            Cells(sat, "G") = sat - 1
            Cells(sat, "H") = Cells(c.Row, "B")
            Cells(sat, "I") = Cells(c.Row, "C")
            Cells(sat, "J") = Cells(c.Row, "D")
            Cells(c.Row, "C").Interior.ColorIndex = 4
            sat = sat + 1
          
            Set c = [B:B].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If

End Sub

 

[samedgunduz]

Süpersiniz elinize sağlık.