sütundaki değerlere göre sayfa1,sayfa2,sayfa3 ' e gönderme

[aykut12344]

arkadaşlar isteğim şöyle,

Anasayfada D sütununda Acun Ilıcalı, Hülya Avşar ,Murat Boz , Hande Subaşı şeklinde isimler mevcut. (ekteki dosya örnek çalışma olduğu için 11 veri mevcut ancak uygulamak istediğim veri dosyasında yaklaşık olarak 2 bin den fazla veri var alt alta, bunu dikkate alırsanız çok sevinirim. )

İsteğim; verileri anasayfaya attıktan sonra bir buton ile macro çalışarak; D sütunundaki isimlere bakarak , önceden kendim oluşturduğum Hülya Avşar, Murat Boz, Hande Subaşı ,Acun Ilıcalı sayfalarına, D sütununda gördüğü isme uygun olarak tüm satırdaki değerleri bozmadan sıralı şekilde ismi geçen sayfaya kopyalaması.

Anlatmak istediğimi 11 verilik bir örneğini excel dosyası olarak ekledim.

Şimdiden teşekkürler.

 

[Murat OSMA]

Arama yaparsanız bu konu ile ilgili sitede onlarca örnek bulabilirsiniz..


Şu kodları bir deneyiniz;

Sub SayfaAktar()
Dim i, j As Long, Sayfa As String, S1 As Worksheet
Set S1 = Sheets("Anasayfa")
Application.ScreenUpdating = False
For j = 2 To Worksheets.Count
    Sheets(j).Cells.Delete Shift:=xlUp
Next j
For i = 2 To S1.[A65536].End(3).Row
    Sayfa = Cells(i, "D")
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sayfa
            S1.Select
        End If
    S1.Range("A1:I1").Copy Sheets(Sayfa).Range("A1")
    S1.Range("A" & i & ":I" & i).Copy Sheets(Sayfa).Range("A" & Sheets(Sayfa).[A65536].End(3).Row + 1)
    Sheets(Sayfa).Range("A:I").EntireColumn.AutoFit
Next i
Set S1 = Nothing
Application.ScreenUpdating = True
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function