Veriyi Sayfalara Bölmek

[seemsiyah]

Öncelikle merhabalar;

Elimde buradan örneğini görebileceğiniz şekilde verilerin olduğu bir dosya mevcut. Verileri örnekteki gibi, sayfalara bölmek istiyorum. Ancak veriler çok olduğu zaman bunu manuel yapmak çok fazla vakit alıyor.

Biraz araştırdım ancak makro kullanmam gerekiyormuş. Bulduğum örnekleri de bir türlü bu şekle uyduramadım.

Yardımcı olabilirseniz çok sevinirim.

 

[PLİNT]

Merhaba
Örneği incelermisiniz?
http://s3.dosya.tc/server6/vem0bl/ORNEK.zip.html

Private Sub CommandButton1_Click()
Set s1 = Sheets("Sayfa1")
For x = 1 To Application.Sheets.Count
Sheets(x).Activate
If Sheets(x).Name <> s1.Name Then
Set s2 = Sheets(x)
a = s1.Cells(Rows.Count, 1).End(3).Row
Set b = s1.Range("A1:A" & a).Find(s2.Name)
If Not b Is Nothing Then
sor = MsgBox("SAYFA TEMİZLENSİN Mİ?", vbYesNo)
If sor = vbYes Then s2.[a2:f10000] = Empty
n = s2.Cells(Rows.Count, 1).End(3).Row + 2
n2 = b.Row
For c = n2 To a
s1.Range("a" & n2 & ":f" & n2).Copy
s2.Cells(n, 1).PasteSpecial
Application.CutCopyMode = False
If Trim(s1.Cells(n2, 1).Value) = s2.Name Then v = v + 1
If v > 1 Then Exit For
n = n + 1: n2 = n2 + 1
Next
n = 0: n2 = 0: v = 0
End If: End If
Next
End Sub

 

[seemsiyah]

Ellerinize sağlık. Son bir soru, Sayfa1deki veriye göre çalışma sayfalarını (1.sınıf, 2.sınıf, 3.sınıf) otomatik oluşturma imkanım var mı?

 

[PLİNT]

Ellerinize sağlık. Son bir soru, Sayfa1deki veriye göre çalışma sayfalarını (1.sınıf, 2.sınıf, 3.sınıf) otomatik oluşturma imkanım var mı?

Merhaba
Uygulayacağınız dosyadaki sayfa da örnek dosyanızdaki "Sayfa1" deki veri girişleriyle olmalıdır.
Kodların işleyişi "Sınıf1"'i "A" sütununda döngüyle bulduktan sonra arama yapıp
aynı sütunda 2. "Sınıf1" yazan satırı bulacak iki satır aralığını oluşturulan sayfaya kopyalayacak. 3. "Sınıf1" olursa hata verecektir.
Eki inceleyiniz.
http://s3.dosya.tc/server6/2qyhl6/ORNEK2.zip.html

 Private Sub CommandButton1_Click()
Set s1 = Sheets("Sayfa1")
For Each c In ActiveWorkbook.Worksheets
Application.DisplayAlerts = False
If c.Name <> s1.Name Then Sheets(c.Name).Delete
Application.DisplayAlerts = False
Next
For a = 3 To Cells(Rows.Count, 1).End(3).Row
If Cells(a, 1).Value Like "*" & "SINIF" Then
If Len("SINIF") <> Len(Trim(Cells(a, 1).Value)) Then
If m = Empty Then
m = Trim(Cells(a, 1).Value)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Trim(Cells(a, 1).Value)
End If
Set s2 = Sheets(Sheets.Count)
Set h = Range("a" & a + 1 & ":a" & Cells(Rows.Count, 1).End(3).Row).Find(m)
If Not h Is Nothing Then
Range("a1:f1").Copy
s2.Range("a1").PasteSpecial
Range("a" & a & ":f" & h.Row).Copy
s2.Range("a3").PasteSpecial
Application.CutCopyMode = False
s2.Range("a3").Select
a = a + (h.Row - a)
m = Empty
End If: End If: End If
Next
End Sub

 

[seemsiyah]

merhabalar, ilginiz için ne kadar teşekkür etsem az.

üzerine bir kaç ekleme yapıp, çalışma sayfalarını ayrı çalışma kitabı olarak da kaydettim, tadından yenmez oldu

tekrar çok çok teşekkürler