Koşula Göre Tarihleri Yana Aktarma ve Sayma

[Utekiner]

Merhaba,

Resimdeki örnekteki gibi bir çalışmam var. A ve B sütunlarındaki veriyi E ve J sütunlarındaki gibi nasıl yapabilirim. Destek olur musunuz.

Makro veya formül olarak hiç farketmez.

 

[muygun]

Merhaba;
Örnek dosya ekleyin.
İyi çalışmalar.

 

[Utekiner]

@muygun Örnek ektedir.

Örnek Dosya

 

[Korhan Ayhan]

Özet Tablo ile aşağıdaki gibi yapabilirsiniz.

 

[Utekiner]

@Korhan Ayhan Bey özet tablo ile yapıyorum. Sürekli bilgilerin yanına aktarma yapıyorum. Ben direk örnekteki gibi hale getirmek istiyorum.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Rapor()
    Dim Veri As Variant, Liste As Variant, Dizi As Object, Kayit As Variant, Adres As String
    Dim X As Long, Say As Long, Max_Sutun As Integer, Sutun As Integer, Zaman As Double
    
    Application.ScreenUpdating = False
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    With Worksheets("Sheet1")
        Veri = .Range("A2:B" & .Cells(.Rows.Count, 1).End(3).Row).Value
        .Range("E:AZ").Clear
        .Range("E:E").NumberFormat = "@"
        .Range("E1") = "Barkod No"
        .Range("E1").Font.Bold = True
        .Range("E1").Font.Underline = xlUnderlineStyleSingle
    
        ReDim Liste(1 To UBound(Veri), 1 To 100)
        
        With Dizi
            For X = 1 To UBound(Veri)
                If Not .Exists(Veri(X, 1)) Then
                    Say = Say + 1
                    .Add Veri(X, 1), Array(Say, 1)
                    ReDim Preserve Liste(1 To UBound(Veri), 1 To 100)
                    Liste(Say, 1) = Veri(X, 1)
                End If
                
                Kayit = .Item(Veri(X, 1))
                Kayit(1) = Kayit(1) + 1
                Liste(Kayit(0), Kayit(1)) = Veri(X, 2)
                .Item(Veri(X, 1)) = Kayit
                Max_Sutun = WorksheetFunction.Max(Max_Sutun, Kayit(1))
            Next
        End With
    
        .Range("E2").Resize(Say, Max_Sutun).Value = Liste
         Adres = .Cells(2, Max_Sutun).Offset(0, 4).Address(0, 0)
        .Cells(1, Max_Sutun).Offset(0, 5) = "Say"
        .Cells(1, Max_Sutun).Offset(0, 5).Font.Bold = True
        .Cells(1, Max_Sutun).Offset(0, 5).Font.ColorIndex = 3
        .Cells(2, Max_Sutun).Offset(0, 5).Resize(Say) = "=COUNTA(F2:" & Adres & ")"
        .Cells(2, Max_Sutun).Offset(0, 5).Resize(Say).Value = .Cells(2, Max_Sutun).Offset(0, 5).Resize(Say).Value
        .Cells.EntireColumn.AutoFit
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Utekiner]

@Korhan Ayhan hocam tam istediğim olmuş. Elinize sağlık.