Makro ile çekip gruplama

[koboy]

abi kusura bakma uğraştırıyorum yine aynı tutarı 11,5 yazıyor
Resim ekledim abi

 

[koboy]

Yusuf bey merhaba sumıf yapıyor aynı rakamı diğer yerlerede getiriyor

 

[YUSUF44]

Aşağıdaki gibi oluyor mu?

Sub kasap()


Set s1 = Sheets("VERİ")
Set s2 = ActiveSheet
Application.ScreenUpdating = False
son = s1.Cells(Rows.Count, "B").End(3).Row
s2.Rows("5:" & Rows.Count).Delete
tarih = s2.[B1]
For bolge = 2 To son
    If s1.Cells(bolge, "E") = tarih Then
        If WorksheetFunction.CountIfs(s1.Range("L1:L" & bolge), s1.Cells(bolge, "L"), s1.Range("E1:E" & bolge), tarih) = 1 Then
            If s2.[A5] <> "" Then
                sutun = sutun + 4
            Else
                sutun = 1
            End If
            If sutun > 1 Then Columns(sutun - 1).ColumnWidth = 4
            yeni = WorksheetFunction.Max(s2.Cells(Rows.Count, sutun).End(3).Row + 2, 5)
            bolgeadi = s1.Cells(bolge, "L")
            s2.Cells(yeni, sutun) = "BÖLGE"
            s2.Cells(yeni, sutun + 1) = bolgeadi
            s2.Cells(yeni + 2, sutun) = "MÜŞTERİ"
            s2.Cells(yeni + 2, sutun + 1) = "SİPARİŞ MİKTARI"
            s2.Cells(yeni + 2, sutun + 2) = "FATURA EDİLEN MİKTAR"
            s2.Cells(yeni, sutun).Interior.Color = RGB(200, 159, 93)
            s2.Cells(yeni, sutun).Font.Color = RGB(255, 255, 255)
            s2.Cells(yeni, sutun + 1).Interior.Color = RGB(221, 198, 157)
            s2.Range(Cells(yeni, sutun), Cells(yeni + 2, sutun + 2)).Font.Bold = True
        
            s2.Range(Cells(yeni + 2, sutun), Cells(yeni + 2, sutun + 2)).Interior.Color = RGB(200, 159, 93)
            s2.Range(Cells(yeni + 2, sutun), Cells(yeni + 2, sutun + 2)).Font.Bold = True
            s2.Range(Cells(yeni + 2, sutun), Cells(yeni + 2, sutun + 2)).Font.Color = RGB(255, 255, 255)
            With s2.Range(Cells(yeni, sutun), Cells(yeni + 2, sutun + 2))
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
             Columns(sutun).ColumnWidth = 32
            Columns(sutun).ColumnWidth = 32
            Columns(sutun + 1).ColumnWidth = 14
            Columns(sutun + 2).ColumnWidth = 14
            Range("A5" & i).EntireRow.RowHeight = 23
            For musteri = bolge To son
                If s1.Cells(musteri, "E") = tarih And s1.Cells(musteri, "L") = bolgeadi Then
                    If WorksheetFunction.CountIfs(s1.Range("B1:B" & musteri), s1.Cells(musteri, "B"), s1.Range("E1:E" & musteri), tarih) = 1 Then
                        musteriadi = s1.Cells(musteri, "B")
                        yeni1 = s2.Cells(Rows.Count, sutun).End(3).Row + 1
                        s2.Cells(yeni1, sutun) = musteriadi
                        s2.Range(Cells(yeni1, sutun), Cells(yeni1, sutun + 2)).Interior.Color = RGB(243, 236, 222)
                        s2.Range(Cells(yeni1, sutun), Cells(yeni1, sutun + 2)).Font.Bold = True
                        With s2.Range(Cells(yeni1, sutun), Cells(yeni1, sutun + 2))
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                        End With
                              
                        For urun = musteri To son
                            If s1.Cells(urun, "B") = musteriadi And s1.Cells(urun, "E") = tarih Then
                                    urunadi = s1.Cells(urun, "C")
                                    yeni2 = s2.Cells(Rows.Count, sutun).End(3).Row + 1
                                    s2.Cells(yeni2, sutun) = urunadi
                                    s2.Cells(yeni2, sutun + 1) = s1.Cells(urun, "G")
                                    s2.Cells(yeni2, sutun + 2) = s1.Cells(urun, "H")
                                    s2.Range(Cells(yeni2, sutun), Cells(yeni2, sutun + 2)).Font.Bold = False
                                    s2.Range(Cells(yeni2, sutun), Cells(yeni2, sutun + 2)).Interior.Color = xlNone
                                    s2.Range(Cells(7, sutun + 1), Cells(yeni2, sutun + 2)).NumberFormat = "#,##0.000"
                            End If
                        Next
                    End If
                End If
            Next
        End If
    End If
Columns(sutun).EntireColumn.AutoFit
Columns(sutun + 1).EntireColumn.AutoFit
Columns(sutun + 2).EntireColumn.AutoFit
Next
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAMLANDI"
End Sub

 

[koboy]

Günaydın evet oldu teşekkürler