başka sayfaya kayıtları toplama

[limanC34]

Selam Arkadaşlar
Sayfalardan istediğim satırları mausla belirtip KAYDET sayfasına butona tıklayıp alt alta gönderebilirmiyim?Ancak aynı kayıtlar tekrar gönderilemesin.
Teşekkürler.

 

[limanC34]

Selam Arkadaşlar
Gözden kaçtı eminim yardımcı olursanız sevinirim.
Teşekkürler.

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodları bir modul sayfasına kopyalayınız ve sayfadaki düğmeye bağlayınız.

Sub Kaydet()
    Dim str As Range
    Dim i As Integer
    Dim y As Integer
    Dim son As Integer
    
[COLOR=darkgreen]    'Seçim bir hücre aralığı mı ? Öyleyse[/COLOR]
    If TypeOf Selection Is Range Then
        
[COLOR=darkgreen]        'Seçimdeki herbir hücre için[/COLOR]
        For Each str In Selection
        
[COLOR=darkgreen]            'KAYDET sayfası ile birlikte[/COLOR]
            With Sheets("KAYDET")
                
[COLOR=darkgreen]                'Kaydet sayfasındaki tüm dolu satırları
                'tarayacak şekilde döngüye gir[/COLOR]
                For i = 2 To .Cells(65536, 1).End(xlUp).Row
[COLOR=darkgreen]                    'Eğer seçimdeki ilgili hücrenin ilk 5 hücresi
                    'Kaydet sayfasındaki ilk beş hücre ile eşitse[/COLOR]
                    If Cells(str.Row, 1) & _
                        Cells(str.Row, 2) & _
                          Cells(str.Row, 3) & _
                            Cells(str.Row, 4) & _
                              Cells(str.Row, 5) = _
                                                   .Cells(i, 1) & _
                                                    .Cells(i, 2) & _
                                                     .Cells(i, 3) & _
                                                      .Cells(i, 4) & _
                                                        .Cells(i, 5) Then
[COLOR=darkgreen]                        'eşitlik sayacını bir artır[/COLOR]
                        y = y + 1
[COLOR=darkgreen]                        'Döngüden çık[/COLOR]
                        Exit For
                     End If
                 Next i
                 
[COLOR=darkgreen]                 'Eğer eşitlik sayacı 0 ise[/COLOR]
                 If y = 0 Then
[COLOR=darkgreen]                    'Kaydet sayfasındaki son boş satırı bul[/COLOR]
                    son = .Cells(65536, 1).End(xlUp).Row + 1
[COLOR=darkgreen]                      'Son boş satıra, seçimdeki ilgili hücreleri aktar[/COLOR]
                      .Range(.Cells(son, 1), .Cells(son, 5)).Value = _
                          Range(Cells(str.Row, 1), Cells(str.Row, 5)).Value
                 End If
[COLOR=darkgreen]                 'eşitlik sayacını sıfırla[/COLOR]
                 y = 0
            
            End With
        Next
    
    End If
End Sub

 

[limanC34]

Sayın Şaban Sertkaya
Değerli çözümünüz için çok teşekkür ederim.
Saygılarımla.

 

[Ferhat Pazarçevirdi]

Oradan bakınca, Şaban bey gibi mi görünüyorum yoksa

İnsan insana benzermiş ama; kendisiyle, hiç yüzyüze görüşme fırsatımız olmadığı için benzerlik konusunda bir fikir yürütemeyeceğim ...

Bu arada; Şaban bey'in de kulaklarını çınlattık ...

 

[limanC34]

Ferhat Hocamdam özür dilerim

Hocam
Oldu bir yanlışlık AFFET
İşte serbest kürsü
İşte itiraf
ÖZÜR DİLERİM
Karıştırdım bir an
Daha fazla kızartma beni.Şuan bayabi utanıyorum.
Saygılarımla.

 

[Ferhat Pazarçevirdi]

İlahi ! .... Latife olsun diye yazdım onları limanC34 Gönüller bir olsun, yeter ...

Hassasiyetiniz için de ayrıca teşekkür ederim.