özet tablo değerlerini yeni sayfalara atmak

[abufkes]

Başka yerde sordum ama cevap alamadım.
Sayın Üstadlar, bilenler
Özet tablonun sonuçlarını ayrı ayrı yeni çalışma sayfaları olarak kaydettirmek mümkün mü?
Saygılarımla

 

[Ömer]

Merhaba,

Module kopyalayıp çalıştırın.

Sub SayfalaraDagit()
    
    Dim d As Object, Sv As Worksheet, i As Long, deg As Variant, son As Long
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Set d = CreateObject("Scripting.Dictionary")
    Set Sv = Sheets("veri")
    
    Sv.Select
    Range("A2:C" & Rows.Count).Sort Range("A2")
    
    For i = Worksheets.Count To 1 Step -1
        With Sheets(i)
            If .Name <> "özet tablo" And .Name <> "veri" Then
                .Delete
            End If
        End With
    Next i
    
    For i = 2 To Sv.Cells(Rows.Count, "A").End(xlUp).Row
        deg = Sv.Cells(i, "A")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = deg
            Range("A1") = Sv.Cells(i, "B")
            Range("B1") = Sv.Cells(i, "C")
        Else
            son = Cells(Rows.Count, "A").End(xlUp).Row + 1
            Cells(son, "A") = Sv.Cells(i, "B")
            Cells(son, "B") = Sv.Cells(i, "C")
        End If
    Next i
 
    Sv.Select
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
End Sub

.

 

[abufkes]

çok teşekkür ederim Ömer Bey,
müsadenizle bir sorum daha var ;
bunları yeni çalışma sayfaları olarak değil de , masa üstüne yeni excel dosyaları olarak kayıt etmek mümkün mü?

 

[Ömer]

Merhaba,

Linki inceleyiniz. Buna benzer bir konu.

http://www.excel.web.tr/f48/filitre-hucerisindeki-bilgilere-gore-kaydetme-t95684.html

.

 

[abufkes]

Ömer Bey verdğiniz linkteki örneği inceledim tam benim istediğim şey lakin kod bilgim çok zayıf ve bir türlü kendi isteğime uyarlayamadım hala da uğraşıyorum
Beni bu samanlıktan kurtarırsanız sevinirim.
Formatımı yeni excel sayfalarına döktürebilirseniz çok sevinirim.

 

[Ömer]

Bu şekilde deneyin. Yalnız önce masa üstünde Yedek adıyla bir klasör oluşturun. Açılan sayfalar bu klasörde toplanacak.

Sub OzetKaydet()
 
    Dim Sv As Worksheet, Sx As Worksheet, i As Long, dosya As String
 
    Set Sv = Sheets("veri")
 
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "xxx"
 
    Set Sx = Sheets("xxx")
 
    Sv.Select
    Range("A2:C" & Rows.Count).Sort Range("A2")
 
    Sv.Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("O1"), Unique:=True
 
    For i = 2 To Sv.Cells(Rows.Count, "O").End(xlUp).Row
        Sv.Range("A:C").AutoFilter Field:=1, Criteria1:=Sv.Cells(i, "O")
 
        Sx.Select: Cells.Clear
        Sv.Range("A:C").Copy Sx.Range("A1")
        Sx.Rows(1).Delete
 
     dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
        "\[COLOR=red]Yedek[/COLOR]" & Application.PathSeparator & Sv.Cells(i, "O") & ".xls"
 
        ActiveSheet.Copy
        ActiveWorkbook.SaveAs Filename:=dosya: ActiveWorkbook.Close
    Next i
 
    Sx.Delete: Sv.Select: ActiveSheet.AutoFilterMode = False: [O:O].Clear
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
 
End Sub

.

 

[abufkes]

çok çok teşekkür ederim Allah razı olsun