Veriyi sayfalara dagıt makrosunda değişiklik

[ayhan7tr]

Sevgili arkadaşlar,
Kullandığım makro d1 den başlıyor fakat d1 de başka bilgiler olduğu için d7 den başlasın istedim bir türlü yapamadım, bir de hesap ismi ile ilgili yeni sayfa açtığında hücre stillerini koruyabilirmi.

Teşekkür ederim.
Saygılarımla,
Ayhan

Option Explicit

Sub DAGIT()
Dim s1 As Worksheet
Dim sY As Worksheet
Dim ALAN As Range
Dim r As Integer
Dim c As Range
Set s1 = Sheets("Mayıs")
Set ALAN = Range("VERİTABANI")


s1.Columns("d:d").Copy _
Destination:=Range("P1")
s1.Columns("P").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("N1"), Unique:=True
r = Cells(Rows.Count, "N").End(xlUp).Row


Range("P1").Value = Range("D1").Value

For Each c In Range("N2:N" & r)

s1.Range("P2").Value = c.Value

If SAYFA(c.Value) Then
Sheets(c.Value).Cells.Clear
ALAN.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("VERİ").Range("P12"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Else
Set sY = Sheets.Add
sY.Move After:=Worksheets(Worksheets.Count)
sY.Name = c.Value
ALAN.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Mayıs").Range("P12"), _
CopyToRange:=sY.Range("B2"), _
Unique:=True
End If
Next
s1.Select
s1.Columns("N").Delete
End Sub
Function SAYFA(SAYFAADI As String) As Boolean
On Error Resume Next
SAYFA = CBool(Len(Worksheets(SAYFAADI).Name) > 0)
End Function

 

[Korhan Ayhan]

Selamlar,

Ekte örnek dosyanız üzerinde gerekli düzenlemeleri yaptım. İncelermisiniz.