Sayfa biçimini silmeden verinin alt satıra eklenmesi

[ayhan7tr]

Değerli Arkadaşlar,
Kullandığım dağıt makrosu örnekte olduğu gibi liste sayfasındaki verileri hesap isimlerine göre sayfalara dağıtıyor eğer sayfa yoksa yeni sayfa açıyor, eğer sayfa varsa sayfayı silip üstüne tekrar yazıyor. Ben daha önce aynı adla açılmış olan sayfa biçimini (üzerine ilaveler yaptığıım için) silmeden gelen veriyi bir alt satıra yazdırmak istiyorum. Yeni sayfa açılmasında problemim yok.
Yardımlarınız için teşekkür ederim.

Saygı ve sevgilerimle,

Ayhan
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("liste")
Set ALAN = Range("VERİTABANI")


s1.Columns("b:b").Copy _
Destination:=s1.Range("L1")
s1.Columns("L:L").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row


Range("L1").Value = Range("b1").Value

For Each c In Range("J2:J" & r)

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

If Sheet(c.Value) Then
Sheets(c.Value).Cells.Clear
ALAN.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("liste").Range("L1:L2"), _
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("liste").Range("L1:L2"), _
CopyToRange:=sY.Range("A1"), _
Unique:=False
End If
Next
s1.Select
s1.Columns("J:L").Delete
End Sub
Function Sheet(Sheetname As String) As Boolean
On Error Resume Next
Sheet = CBool(Len(Worksheets(Sheetname).Name) > 0)
End Function

 

[ayhan7tr]

Yardımlarınızı rica edebilirmiyim.

Saygılarımla, Ayhan

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub SAYFALARA_DAĞIT()
    Dim SL As Worksheet, SY As Worksheet
    Dim ALAN As Range, HESAP As Range, VERİ As Range
    Dim SATIR1 As Integer, SATIR2 As Integer
    Set SL = Sheets("liste")
    Set ALAN = Range("VERİTABANI")
    
    SL.Columns(2).AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=SL.Range("J1"), Unique:=True
    
    SATIR1 = Cells(65536, "J").End(3).Row
    
    For Each HESAP In SL.Range("J2:J" & SATIR1)
    If Sheet(HESAP.Value) Then
        For Each VERİ In SL.Range("B2:B" & SL.[B65536].End(3).Row)
        If VERİ.Value = HESAP.Value Then
        SATIR2 = Sheets(HESAP.Value).[A65536].End(3).Row + 1
        Sheets(HESAP.Value).Cells(SATIR2, 1) = WorksheetFunction.Max(Sheets(HESAP.Value).Columns(1)) + 1
        Sheets(HESAP.Value).Cells(SATIR2, 2) = VERİ.Value
        Sheets(HESAP.Value).Cells(SATIR2, 3) = VERİ.Offset(0, 1).Value
        Sheets(HESAP.Value).Cells(SATIR2, 4) = VERİ.Offset(0, 2).Value
        Sheets(HESAP.Value).Cells(SATIR2, 5) = VERİ.Offset(0, 3).Value
        Sheets(HESAP.Value).Cells(SATIR2, 6) = VERİ.Offset(0, 4).Value
        End If
        Next
    
        Else
    
        Set SY = Sheets.Add
        SY.Move After:=Worksheets(Worksheets.Count)
        SY.Name = HESAP.Value
        ALAN.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=SL.Range("L1:L2"), _
        CopyToRange:=SY.Range("A1"), Unique:=False
        End If
    Next
    SL.Select
    SL.Columns(10).Delete
End Sub
 
Function Sheet(Sheetname As String) As Boolean
    On Error Resume Next
    Sheet = CBool(Len(Worksheets(Sheetname).Name) > 0)
End Function

 

[ayhan7tr]

Korhan Bey,
Çabanız için çok teşekkür ederim fakat macroyu çalıştırınca hesap isimlerine göre sayfa açıyor fakat liste sayfasında ne kadar veri varsa hepsini açılan sayfalara kopyalıyor.
Saygılarımla,
Ayhan

 

[Korhan Ayhan]

Selamlar,

Sizin eklediğiniz örnek dosyaya göre kodu düzenlemiştim. Hangi sayfayı çoğaltmak istediğinizi belirtmediğiniz için o kısıma müdahale etmek istemedim. Bu durumda çalışmanıza Şablon isminde bir sayfa ekledim. Ve yeni hesaplarda bu sayfayı kullandım. Ekteki örnek dosyayı incelermisiniz.

 

[ayhan7tr]

Sayın Korhan Bey,

Beklediğimin ve düşündüğümün ötesinde güzel olmuş, verdiğim tüm zahmetler için özür diler, her şey için çok teşekkür ederim.
Tüm güzellikler sizinle olsun.
Saygılarmıla,
Ayhan