• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Grup toplama makro

  • Konbuyu başlatan Konbuyu başlatan koboy
  • Başlangıç tarihi Başlangıç tarihi
K

koboy

Katılım
1 Ağustos 2006
Mesajlar
179
Merhabalar çalışma sayfasında bir dosya ekliyorum.
Burada makro ile çekiyorum ama benim sayfada belirttiğim gibi ayrı ayrı hücrelerdeki bilgilere göre grup almak istiyorum
 

Ekli dosyalar

ya sadece sarı olan kısımdaki gruba filtre yaparak çekmeyi gösterin o bile yeterli
 
Sabahtan beri yapmak için uğraşıyorum, kafam kazan oldu o_O

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

PHP: 
Sub kasap()
Set s1 = Sheets("VERİ")
Set s2 = Sheets("GİRİS (2)")
son = s1.Cells(Rows.Count, "B").End(3).Row
s2.Range("A5:C" & Rows.Count).Delete
tarih = s2.[B1]
For bölge = 2 To son
    If s1.Cells(bölge, "E") = tarih Then
        If WorksheetFunction.CountIfs(s1.Range("L1:L" & bölge), s1.Cells(bölge, "L"), s1.Range("E1:E" & bölge), tarih) = 1 Then
            yeni = WorksheetFunction.Max(s2.Cells(Rows.Count, "A").End(3).Row + 2, 5)
            bölgeadı = s1.Cells(bölge, "L")
            s2.Cells(yeni, "A") = "BÖLGE"
            s2.Cells(yeni, "B") = bölgeadı
            s2.Cells(yeni + 2, "A") = "MÜŞTERİ"
            s2.Cells(yeni + 2, "B") = "SİPARİŞ MİKTARI"
            s2.Cells(yeni + 2, "C") = "BEKLEYEN MİKTAR"
            With s2.Cells(yeni, "A").Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 7067390
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            With s2.Cells(yeni, "B").Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 10216447
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            With s2.Range("A" & yeni + 2 & ":C" & yeni + 2).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 7067390
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            s2.Range("A" & yeni + 2 & ":C" & yeni + 2).Font.Bold = True
            With s2.Range("A" & yeni + 2 & ":C" & yeni + 2)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            
            For müşteri = bölge To son
                If s1.Cells(müşteri, "E") = tarih And s1.Cells(müşteri, "L") = bölgeadı Then
                    If WorksheetFunction.CountIfs(s1.Range("B1:B" & müşteri), s1.Cells(müşteri, "B"), s1.Range("E1:E" & müşteri), tarih) = 1 Then
                        müşteriadı = s1.Cells(müşteri, "B")
                        yeni1 = s2.Cells(Rows.Count, "A").End(3).Row + 1
                        s2.Cells(yeni1, "A") = müşteriadı
                        With s2.Range("A" & yeni1 & ":C" & yeni1).Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 13431295
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                        s2.Range("A" & yeni1 & ":C" & yeni1).Font.Bold = True
                        With s2.Range("A" & yeni1 & ":C" & yeni1)
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                            .WrapText = False
                            .Orientation = 0
                            .AddIndent = False
                            .IndentLevel = 0
                            .ShrinkToFit = False
                            .ReadingOrder = xlContext
                            .MergeCells = False
                        End With
                              
                        For ürün = müşteri To son
                            If s1.Cells(ürün, "B") = müşteriadı And s1.Cells(ürün, "E") = tarih Then
                                If WorksheetFunction.CountIfs(s1.Range("L1:L" & ürün), bölgeadı, s1.Range("B1:B" & ürün), müşteriadı, _
                                    s1.Range("C1:C" & ürün), s1.Cells(ürün, "C"), s1.Range("E1:E" & ürün), tarih) = 1 Then
                                    ürünadı = s1.Cells(ürün, "C")
                                    yeni2 = s2.Cells(Rows.Count, "A").End(3).Row + 1
                                    s2.Cells(yeni2, "A") = ürünadı
                                    s2.Cells(yeni2, "B") = WorksheetFunction.SumIfs(s1.Range("G1:G" & son), _
                                        s1.Range("L1:L" & son), bölgeadı, s1.Range("B1:B" & son), müşteriadı, _
                                        s1.Range("C1:C" & son), ürünadı, s1.Range("E1:E" & son), tarih)
                                    s2.Cells(yeni2, "C") = WorksheetFunction.SumIfs(s1.Range("I1:I" & son), _
                                        s1.Range("L1:L" & son), bölgeadı, s1.Range("B1:B" & son), müşteriadı, _
                                        s1.Range("C1:C" & son), ürünadı, s1.Range("E1:E" & son), tarih)
                                    s1.Range("A" & ürün & ":C" & ürün).Font.Bold = False
                                    s1.Range("A" & ürün & ":C" & ürün).Interior.Color = xlNone
                                End If
                            End If
                        Next
                    End If
                End If
            Next
        End If
    End If
Next
End Sub
 
Yusuf bey teşekkür ederim süper olmuş tek bir sorun var dosya boyutu çok yüksek kaydediyor kasma yapıyor.

ben yukarıda örnek ekledim onu uyarlama imkanı varmı
 
Veriler çoğaldıkça döngü miktarı artacağı için kasması normal. Nasıl hızlandırılır fazla bilmiyorum maalesef. Belki aşağıdaki gibi olunca biraz hızlanabilir:

PHP: 
Sub kasap()

Set s1 = Sheets("VERİ")
Set s2 = Sheets("GİRİS (2)")
Application.ScreenUpdating = False
son = s1.Cells(Rows.Count, "B").End(3).Row
s2.Range("A5:C" & Rows.Count).Delete
tarih = s2.[B1]
For bölge = 2 To son
    If s1.Cells(bölge, "E") = tarih Then
        If WorksheetFunction.CountIfs(s1.Range("L1:L" & bölge), s1.Cells(bölge, "L"), s1.Range("E1:E" & bölge), tarih) = 1 Then
            yeni = WorksheetFunction.Max(s2.Cells(Rows.Count, "A").End(3).Row + 2, 5)
            bölgeadı = s1.Cells(bölge, "L")
            s2.Cells(yeni, "A") = "BÖLGE"
            s2.Cells(yeni, "B") = bölgeadı
            s2.Cells(yeni + 2, "A") = "MÜŞTERİ"
            s2.Cells(yeni + 2, "B") = "SİPARİŞ MİKTARI"
            s2.Cells(yeni + 2, "C") = "BEKLEYEN MİKTAR"
            With s2.Cells(yeni, "A").Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 7067390
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            With s2.Cells(yeni, "B").Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 10216447
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            With s2.Range("A" & yeni + 2 & ":C" & yeni + 2).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 7067390
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            s2.Range("A" & yeni + 2 & ":C" & yeni + 2).Font.Bold = True
            With s2.Range("A" & yeni + 2 & ":C" & yeni + 2)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            
            For müşteri = bölge To son
                If s1.Cells(müşteri, "E") = tarih And s1.Cells(müşteri, "L") = bölgeadı Then
                    If WorksheetFunction.CountIfs(s1.Range("B1:B" & müşteri), s1.Cells(müşteri, "B"), s1.Range("E1:E" & müşteri), tarih) = 1 Then
                        müşteriadı = s1.Cells(müşteri, "B")
                        yeni1 = s2.Cells(Rows.Count, "A").End(3).Row + 1
                        s2.Cells(yeni1, "A") = müşteriadı
                        With s2.Range("A" & yeni1 & ":C" & yeni1).Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 13431295
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                        s2.Range("A" & yeni1 & ":C" & yeni1).Font.Bold = True
                        With s2.Range("A" & yeni1 & ":C" & yeni1)
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                            .WrapText = False
                            .Orientation = 0
                            .AddIndent = False
                            .IndentLevel = 0
                            .ShrinkToFit = False
                            .ReadingOrder = xlContext
                            .MergeCells = False
                        End With
                              
                        For ürün = müşteri To son
                            If s1.Cells(ürün, "B") = müşteriadı And s1.Cells(ürün, "E") = tarih Then
                                If WorksheetFunction.CountIfs(s1.Range("L1:L" & ürün), bölgeadı, s1.Range("B1:B" & ürün), müşteriadı, _
                                    s1.Range("C1:C" & ürün), s1.Cells(ürün, "C"), s1.Range("E1:E" & ürün), tarih) = 1 Then
                                    ürünadı = s1.Cells(ürün, "C")
                                    yeni2 = s2.Cells(Rows.Count, "A").End(3).Row + 1
                                    s2.Cells(yeni2, "A") = ürünadı
                                    s2.Cells(yeni2, "B") = WorksheetFunction.SumIfs(s1.Range("G1:G" & son), _
                                        s1.Range("L1:L" & son), bölgeadı, s1.Range("B1:B" & son), müşteriadı, _
                                        s1.Range("C1:C" & son), ürünadı, s1.Range("E1:E" & son), tarih)
                                    s2.Cells(yeni2, "C") = WorksheetFunction.SumIfs(s1.Range("I1:I" & son), _
                                        s1.Range("L1:L" & son), bölgeadı, s1.Range("B1:B" & son), müşteriadı, _
                                        s1.Range("C1:C" & son), ürünadı, s1.Range("E1:E" & son), tarih)
                                    s1.Range("A" & ürün & ":C" & ürün).Font.Bold = False
                                    s1.Range("A" & ürün & ":C" & ürün).Interior.Color = xlNone
                                End If
                            End If
                        Next
                    End If
                End If
            Next
        End If
    End If
Next
Application.ScreenUpdating = True
End Sub

Biçim olarak zaten örnek dosyanızdaki gibi yaptım diye düşünüyorum. Başka nasıl olması gerekiyor?
 
Abi söyle anlatayım alt alta veriyor ya veri sayfasındaki L sütünü alıyor
Aslında benim 5 bölgem var 5 bölgeyide yan yana almak örnek b5 = Anadolu yazdım Anadolu’yu. A -d ye kadar etiler e- g ye kadar
 
Ben makroyu
https://www.excel.web.tr/threads/makro-ile-cekip-gruplama.176343/
Başlığındaki sorunuz için hazırlamıştım ama bu başlık altında cevap vermişim, kusura bakmayın. İki sorunuz aynı mı? Değilse bu cevabı verdiğim linkteki sorunuz için değerlendirin lütfen.

Bu başlık için uygun vaktimde bakmaya çalışırım.
 
Abi aynı başlık aslında ben hazır bir makro buldum onu kendime göre uyarlamaya çalıştım bu konudaki üsteki dosyayı düzenleme ihtimalin varsa çok iyi olur yada yaptığınız makro dediğim olursa da şüper olur yan yana
 
Aşağıdaki kodu deneyiniz (kodları ilk dosyanıza göre ayarladım):

PHP: 
Sub kasap()

Set s1 = Sheets("VERİ")
Set s2 = Sheets("GİRİS (2)")
Application.ScreenUpdating = False
son = s1.Cells(Rows.Count, "B").End(3).Row
s2.Rows("5:" & Rows.Count).Delete
tarih = s2.[B1]
For bölge = 2 To son
    If s1.Cells(bölge, "E") = tarih Then
        If WorksheetFunction.CountIfs(s1.Range("L1:L" & bölge), s1.Cells(bölge, "L"), s1.Range("E1:E" & bölge), tarih) = 1 Then
            If s2.[A5] <> "" Then
                sütun = sütun + 4
            Else
                sütun = 1
            End If
            yeni = WorksheetFunction.Max(s2.Cells(Rows.Count, sütun).End(3).Row + 2, 5)
            bölgeadı = s1.Cells(bölge, "L")
            s2.Cells(yeni, sütun) = "BÖLGE"
            s2.Cells(yeni, sütun + 1) = bölgeadı
            s2.Cells(yeni + 2, sütun) = "MÜŞTERİ"
            s2.Cells(yeni + 2, sütun + 1) = "SİPARİŞ MİKTARI"
            s2.Cells(yeni + 2, sütun + 2) = "BEKLEYEN MİKTAR"
            With s2.Cells(yeni, sütun).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 7067390
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            With s2.Cells(yeni, sütun + 1).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 10216447
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            With s2.Range(Cells(yeni + 2, sütun), Cells(yeni + 2, sütun + 2)).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 7067390
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            s2.Range(Cells(yeni + 2, sütun), Cells(yeni + 2, sütun + 2)).Font.Bold = True
            With s2.Range(Cells(yeni + 2, sütun), Cells(yeni + 2, sütun + 2))
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = False
            End With
            
            For müşteri = bölge To son
                If s1.Cells(müşteri, "E") = tarih And s1.Cells(müşteri, "L") = bölgeadı Then
                    If WorksheetFunction.CountIfs(s1.Range("B1:B" & müşteri), s1.Cells(müşteri, "B"), s1.Range("E1:E" & müşteri), tarih) = 1 Then
                        müşteriadı = s1.Cells(müşteri, "B")
                        yeni1 = s2.Cells(Rows.Count, sütun).End(3).Row + 1
                        s2.Cells(yeni1, sütun) = müşteriadı
                        With s2.Range(Cells(yeni1, sütun), Cells(yeni1, sütun + 2)).Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 13431295
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                        s2.Range(Cells(yeni1, sütun), Cells(yeni1, sütun + 2)).Font.Bold = True
                        With s2.Range(Cells(yeni1, sütun), Cells(yeni1, sütun + 2))
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                            .WrapText = False
                            .Orientation = 0
                            .AddIndent = False
                            .IndentLevel = 0
                            .ShrinkToFit = False
                            .ReadingOrder = xlContext
                            .MergeCells = False
                        End With
                              
                        For ürün = müşteri To son
                            If s1.Cells(ürün, "B") = müşteriadı And s1.Cells(ürün, "E") = tarih Then
                                If WorksheetFunction.CountIfs(s1.Range("L1:L" & ürün), bölgeadı, s1.Range("B1:B" & ürün), müşteriadı, _
                                    s1.Range("C1:C" & ürün), s1.Cells(ürün, "C"), s1.Range("E1:E" & ürün), tarih) = 1 Then
                                    ürünadı = s1.Cells(ürün, "C")
                                    yeni2 = s2.Cells(Rows.Count, sütun).End(3).Row + 1
                                    s2.Cells(yeni2, sütun) = ürünadı
                                    s2.Cells(yeni2, sütun + 1) = WorksheetFunction.SumIfs(s1.Range("G1:G" & son), _
                                        s1.Range("L1:L" & son), bölgeadı, s1.Range("B1:B" & son), müşteriadı, _
                                        s1.Range("C1:C" & son), ürünadı, s1.Range("E1:E" & son), tarih)
                                    s2.Cells(yeni2, sütun + 2) = WorksheetFunction.SumIfs(s1.Range("I1:I" & son), _
                                        s1.Range("L1:L" & son), bölgeadı, s1.Range("B1:B" & son), müşteriadı, _
                                        s1.Range("C1:C" & son), ürünadı, s1.Range("E1:E" & son), tarih)
                                    s2.Range(Cells(yeni2, sütun), Cells(yeni2, sütun + 2)).Font.Bold = False
                                    s2.Range(Cells(yeni2, sütun), Cells(yeni2, sütun + 2)).Interior.Color = xlNone
                                End If
                            End If
                        Next
                    End If
                End If
            Next
        End If
    End If
Next
sonsütun = Cells(7, Columns.Count).End(xlToLeft).Column

Application.ScreenUpdating = True
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst