Sütunda yazan isme göre sheet oluştuma

[levoni]

Arkadaşlar Merhaba,
Benim aşağıdaki konuda mümkünse yardımınıza ihtiyacım var.Yardımcı olabilirseniz çok memnun olurum.Herhalükarda şimdiden tşk ler

Ekli dosyada gönderdiğim Deneme 1.xlsx adlı dosyada F sütununda toplamda 6 farklı isim var.Bu duruma göre 5 de olabilir 7 de olabilir.Yapmak istediğim şey imkanı varsa orada yazan isme göre aynı bir sheet oluşturup ana dosyada ismin olduğu tüm satırı hiçbir yapısını bozmadan ilgili sheete aktarmak istiyorum.Çok kısaca tüm "Ayşe" olanların satırları Ayşe Sheetinde olmalı.
Burda eğer yine mümkünse Sheetin formatı şu şekilde olmalı. Ayşe_Günün tarihi
ve sheete yapıştırırken A2 hücresinden başlaması gerekiyor.
Olması gereken yani yapmak istediğim dosyayıda ekte gönderiyorum.

Tşk ler iyi akşamlar

 

[İhsan Tank]

Arkadaşlar Merhaba,
Benim aşağıdaki konuda mümkünse yardımınıza ihtiyacım var.Yardımcı olabilirseniz çok memnun olurum.Herhalükarda şimdiden tşk ler

Ekli dosyada gönderdiğim Deneme 1.xlsx adlı dosyada F sütununda toplamda 6 farklı isim var.Bu duruma göre 5 de olabilir 7 de olabilir.Yapmak istediğim şey imkanı varsa orada yazan isme göre aynı bir sheet oluşturup ana dosyada ismin olduğu tüm satırı hiçbir yapısını bozmadan ilgili sheete aktarmak istiyorum.Çok kısaca tüm "Ayşe" olanların satırları Ayşe Sheetinde olmalı.
Burda eğer yine mümkünse Sheetin formatı şu şekilde olmalı. Ayşe_Günün tarihi
ve sheete yapıştırırken A2 hücresinden başlaması gerekiyor.
Olması gereken yani yapmak istediğim dosyayıda ekte gönderiyorum.

Tşk ler iyi akşamlar

Merhaba
Boş bir module kopyalayıp dener misiniz_?

Option Explicit
Sub sayfa_oluştur_aktar_61()
Dim ts, kaplan, trabzonspor, hamsi As Date
Dim asi, bordo, mavi
trabzonspor = MsgBox("Sayfalara Ayırıp Aktarım Yapıyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
Set asi = Sheets("Sheet1")
For ts = Sheets.Count To 2 Step -1
Application.DisplayAlerts = False
Sheets(ts).Delete
Application.DisplayAlerts = True
Next
For ts = 2 To asi.Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.CountIf(asi.Range("F2:F" & ts), _
asi.Cells(ts, "F")) = 1 Then
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = asi.Cells(ts, "F")
asi.Rows(1).Copy Destination:=Sheets(Sheets.Count).Rows(2)
End If
Next
For kaplan = 2 To Sheets.Count
bordo = 3
Set ts = asi.Range("F:F").Find(Sheets(kaplan).Name, , , xlWhole)
If Not ts Is Nothing Then
trabzonspor = ts.Address
Do
asi.Rows(ts.Row).Copy Destination:=Sheets(kaplan).Range("A" & bordo)
bordo = bordo + 1
Set ts = asi.Range("F:F").FindNext(ts)
Loop While Not ts Is Nothing And ts.Address <> trabzonspor
End If
Sheets(kaplan).Name = Sheets(kaplan).Name & "_" & Format(Now, "dd.mm.yyyy")
Next
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & vbLf _
& "Sayfalara Ayırıp Aktarım Yaptım", , "Bitiş"
End Sub

 

[levoni]

Sayın İhsan Tank,
Çok tşk ederim ellerinize sağlık.10 numara çalıştı.

 

[İhsan Tank]

Sayın İhsan Tank,
Çok tşk ederim ellerinize sağlık.10 numara çalıştı.

Rica ederim
:keyif: