Makroda tek listeyi sayfalara bölme ve alt toplam alma

[hakansali]

Selamlar arkadaşlar.

Ekte sunduğum 2 örnek dosyam var.
Makro uygulaması ile
"ilkdata" dosyamdaki tüm verileri,
"nihaidata" dosyasındaki şekilde sayfalara dağıtmak ve alttoplamlarını almak istiyorum.

Kısacası uygulama;
1-"ilkdata" daki verilerde 1.sütundaki her bir değişkenin tüm satırlarını, aynı değişken adındaki yeni bir sayfa açarak, kes veya kopyala yapıştır yapacak.
2-bu her değişkene ait yeni her bir sayfada alt toplam uygulaması yapacak.

çok sık karşıma gelen bu raporda en hızlı çözüm ne olur tavsiye ve yardımlarınızı rica ediyorum. şimdiden çok çok teşekkürler.

Iyi çalışmalar.

 

[mancubus]

aşağıdaki gibi bir kod mevcut.

yeni bir kitap olarak değil aynı kitabın içinde yeni sayfalar oluşturuyor.

ayrı bir kitap ta yapılabilir. bunun için koda eklenecek satırlara en altta yer verdim.

yalnız aratoplam almak hem sayfadan hem de makro ile çok uzun süren bir işlem.
müşteri sayısı çok fazla ise saatler sürebilir.

ben test ettim. oldu.
yine de asıl dosyanın bir kopyası üzerinden test etmek yeterli.


kodun içindeki kırmızı açıklama ve yeşid satıra dikkat.

Option Explicit

Sub ParseItems()

'Author:    Jerry Beaucaire
'Date:      11/11/2009
'Summary:   Based on selected column, data is filtered to individual sheets
'           Creates sheets and sorts sheets alphabetically in workbook
'           6/10/2010 - added check to abort if only one value in vCol
'           7/22/2010 - added ability to parse numeric values consistently
'           11/16/2011 - changed way Unique values are collected, no Adv Filter
'https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/sheet1-to-sheets

Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 2
 
'Sheet with data in it
   Set ws = Sheets("SATIŞLAR")

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:E1"
    TitleRow = Range(vTitles).Cells(1).Row

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from vCol
    iCol = ws.Columns.Count
    ws.Cells(1, iCol) = "key"
    
    For Itm = 2 To LR
        On Error Resume Next
        If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
            .Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
               ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
        End If
    Next Itm
'Sort the temporary list
[COLOR="Red"]' alfabetik sıralama için aşağıdaki ws'den önceki ' işaretinin  silmek yeterli:[/COLOR]
[COLOR="Lime"]    'ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal[/COLOR]
'Put list into an array for looping
    MyArr = Application.WorksheetFunction.Transpose _
        (ws.Columns(iCol).SpecialCells(xlCellTypeConstants))

'clear temporary list
    ws.Columns(iCol).Clear

'Turn on the autofilter
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
'In case values are numerical, we convert them to text with ""
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) & ""
    
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(Itm) & ""
        Else                                                      'clear sheet if it exists
            Sheets(MyArr(Itm) & "").Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(Itm) & "").Cells.Clear
        End If
    
        ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy _
            Sheets(MyArr(Itm) & "").Range("A1")
        
        Sheets(MyArr(Itm) & "").Range("A1").Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(4, 6), _
            Replace:=True, PageBreaks:=False, SummaryBelowData:=True

        ws.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(MyArr(Itm) & "").Range("A" & Rows.Count) _
                             .End(xlUp).Row - Range(vTitles).Rows.Count
        Sheets(MyArr(Itm) & "").Columns.AutoFit
    Next Itm
    
'Cleanup
    ws.AutoFilterMode = False
        ws.Activate
    MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"

Application.ScreenUpdating = True

End Sub

SATIŞLAR sayfasını silerek ayrı kitap yapmak için Application.ScreenUpdating = True'dan önce gelmek üzere koda aşağıdaki satırları ekleyebilirsin.

Dim wb As Workbook
Dim fPath As String
Set wb = ThisWorkbook
fPath = wb.Path & "\"

Application.DisplayAlerts = False
ws.Delete
wb.SaveAs fPath & "nihai data", FileFormat:=56
Application.DisplayAlerts = True

 

[hakansali]

çok saolasın hızlı cevap ve uğraş için, ellerin dert görmesin. çok pratik oldu benim için..

 

[mancubus]

rica ederim.
ben hazır kodu bir kaç satır değişiklikle senin dosyaya uyarladım sadece.

 

[adoen]

Merhaba,

Aynı makroyu sadece A kolonundaki değerlere göre sayfa oluşturacak şekilde nasıl revize edebiliriz.
Şimdiden teşekkür ederim.