satırdan sayfaya alt alta veri aktarma

[gkhnylcn]

Selam.
Ekteki dosya da yapmak istediğim şey;
"OYUNCU LİSTESİ" sayfasında sarı renkli alandaki verileri "O1" sayfasındaki kırmızı renkli alana taşımak. Fakat sarı renkli alandaki veriler her hafta yenilenecek ve her aktarma işleminde "O1" sayfasındaki en son dolu satırın altına aktarmak istiyorum. Aktarma işlemini bir buton ile yapmak istiyorum butona basınca gördüğü verileri en son dolu satırın altına atsın. yardımcı olabilirseniz diğer satırlar için ben tek tek uygulamasını yapacagım. Her bir oyuncum için farklı bir sayfa açacagım daha sonra ve her birine bir buton ekleyerek gerekli kodları yazacagım.
Şimdiden teşekkür ederim.

 

[Orion1]

Bütün verileri ilili sayfa varsa yani a sütundaki yazılı olanı varsa o sayfaya atar.
Dosyanız ektedir.

Sub sayfalara_aktar()
Dim sh As Worksheet, s1 As Worksheet, sat1 As Long, sat As Long, i As Long
Dim k As Range, adr As String
Set s1 = Sheets("OYUNCU_LİSTESİ")
sat1 = s1.Cells(65536, "A").End(xlUp).Row
Application.ScreenUpdating = True
For i = 4 To sat1
        If WorksheetFunction.CountIf(s1.Range("A4:A" & i), s1.Cells(i, "A").Value) = 1 Then
            For Each sh In Worksheets
                If sh.Name = s1.Cells(i, "A").Value Then
                    sat = sh.Cells(65536, "A").End(xlUp).Row + 1
                    Set k = s1.Range("A4:A" & sat1).Find(s1.Cells(i, "A").Value, , xlValues, xlWhole)
                    If Not k Is Nothing Then
                        adr = k.Address
                        Do
                            If sat >= 65533 Then
                                MsgBox sh.Name & "  İsimli syafaya satır dolduğundan doslayı kayıt girelemedi.", vbCritical, "UYARI"
                                Exit For
                            End If
                           [B][COLOR="Red"] If WorksheetFunction.CountA(s1.Range("D" & k.Row & ":W" & k.Row)) > 0 Then[/COLOR][/B]
                                sh.Range("A" & sat & ":V" & sat).Value = s1.Range("A" & k.Row & ":V" & k.Row).Value
                                sat = sat + 1
                           [B][COLOR="Red"] End If[/COLOR][/B]
                            Set k = s1.Range("A4:A" & sat1).FindNext(k)
                        Loop While Not k Is Nothing And k.Address <> adr
                    End If
                    Exit For
                End If
            Next
        End If
Next
Application.ScreenUpdating = True
MsgBox "Sayfalara Akatrma tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    
                    
End Sub

 

[gkhnylcn]

Evren Üstad çok teşekkür ederim. Tek butonla bütün işi halletmişsin. Bana kalsa her oyuncuya bi button ekleyecektim. Ellerine ve emeğine sağlık.

 

[Orion1]

Evren Üstad çok teşekkür ederim. Tek butonla bütün işi halletmişsin. Bana kalsa her oyuncuya bi button ekleyecektim. Ellerine ve emeğine sağlık.

Rica ederim.
Bunlar bizim için çerez.

 

[gkhnylcn]

Üstad Bişey daha rica edebilir miyim?
Aktar yapınca sadece D ile W arasındaki sütunlardan birisinde bir veri varsa o satırı kopyalasın. Yani satırı A sütunundan itibaren kopyalayacak fakat D ile W arasında herhangi bir veri mevcut ise. Bu sütunlar arasında veri olmayan satırı kopyalamasın.
Eminim bu da senin için çerezdir.
Şimdiden teşekkür ederim.

 

[gkhnylcn]

Acil..acil...

Bütün verileri ilili sayfa varsa yani a sütundaki yazılı olanı varsa o sayfaya atar.
Dosyanız ektedir.

Sub sayfalara_aktar()
Dim sh As Worksheet, s1 As Worksheet, sat1 As Long, sat As Long, i As Long
Dim k As Range, adr As String
Set s1 = Sheets("OYUNCU_LİSTESİ")
sat1 = s1.Cells(65536, "A").End(xlUp).Row
Application.ScreenUpdating = True
For i = 4 To sat1
    If WorksheetFunction.CountIf(s1.Range("A4:A" & i), s1.Cells(i, "A").Value) = 1 Then
        For Each sh In Worksheets
            If sh.Name = s1.Cells(i, "A").Value Then
                sat = sh.Cells(65536, "A").End(xlUp).Row + 1
                Set k = s1.Range("A4:A" & sat1).Find(s1.Cells(i, "A").Value, , xlValues, xlWhole)
                If Not k Is Nothing Then
                    adr = k.Address
                    Do
                        If sat >= 65533 Then
                            MsgBox sh.Name & "  İsimli syafaya satır dolduğundan doslayı kayıt girelemedi.", vbCritical, "UYARI"
                            Exit For
                        End If
                        sh.Range("A" & sat & ":V" & sat).Value = s1.Range("A" & k.Row & ":V" & k.Row).Value
                        sat = sat + 1
                        Set k = s1.Range("A4:A" & sat1).FindNext(k)
                    Loop While Not k Is Nothing And k.Address <> adr
                End If
                Exit For
            End If
        Next
    End If
Next
Application.ScreenUpdating = True
MsgBox "Sayfalara Akatrma tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    
                    
End Sub

Evren üstad acil yardımını bekliyorum...

 

[Orion1]

Evren üstad acil yardımını bekliyorum...

Dosyayı güncelledim.
2 numaralı mesajdan indirebilirsiniz.

 

[gkhnylcn]

teşekkür ederim...