Macro İle Şartlı Veri Saydırma

[cedi007]

Selamlar,
Ektede de eklemiş olduğum excel dosyamda görüleceği üzere, B sütunundaki tarih saat bilgisine göre C sütunundaki verinin kaç adet olduğunu A sütununa karşılık gelen tabloya yazdırmak istiyorum. Örnek tabloyu manuel olarak oluşturdum. Örneğin; X FIRMA sının C sütunundaki unique olan IP verisinin, farklı tarih saat için kaç adet olduğunu saydırmak istiyorum. Yani aynı tarih saat ve saliseyi saydırmayacak.
Bu arada tarih formayım şu şekilde 2023/04/20 10:10:10 tipindedir.

Bu işlemi makro ile yapabilir miyiz, desteğinizi rica ediyorum.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[veyselemre]

Sub test()
    Dim lst, i, say, data, ky1, ky2, al

    With Sheets("Sayfa1")
        lst = .Range("A2:C" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With

    ReDim data(1 To UBound(lst), 1 To 3)

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            ky1 = lst(i, 1) & "|" & lst(i, 3)
            ky2 = ky1 & "|" & Format(lst(i, 2), "ddmmyyyy hhmm")
            If Not .exists(ky1) Then
                say = say + 1
                .Item(ky1) = say
                data(say, 1) = lst(i, 1)
                data(say, 2) = lst(i, 3)
                data(say, 3) = 0
            End If
            If Not .exists(ky2) Then
                al = .Item(ky1)
                data(al, 3) = data(al, 3) + 1
                .Item(ky2) = Null
            End If
        Next i
    End With

    With Sheets("Sayfa1")
        Range("F2:H" & .Cells(Rows.Count, 6).End(3).Row).ClearContents
        Range("F2:H" & say + 1).Value = data
    End With

End Sub

 

[cedi007]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Merhaba,

Emeğinize sağlık öncelikle. Kod çalışıyor ancak istediğim şekilde değil ne yazık ki. Bu kod C sütunundaki verinin kaç tane olduğunu yazdırıyor sadece. Burada B sütunundaki filtrelemeyi almamış. Yani B deki aynı tarih/saat/salise olanları dahil etmesin istiyorum ve sadece 1'ini alsın idi. Buradaki B sütunu kilit noktam aslında. Tarih saat ve salise tek bir hücrede yer alıyor.

 

[cedi007]

Sub test()
    Dim lst, i, say, data, ky1, ky2, al

    With Sheets("Sayfa1")
        lst = .Range("A2:C" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With

    ReDim data(1 To UBound(lst), 1 To 3)

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            ky1 = lst(i, 1) & "|" & lst(i, 3)
            ky2 = ky1 & "|" & Format(lst(i, 2), "ddmmyyyy hhmm")
            If Not .exists(ky1) Then
                say = say + 1
                .Item(ky1) = say
                data(say, 1) = lst(i, 1)
                data(say, 2) = lst(i, 3)
                data(say, 3) = 0
            End If
            If Not .exists(ky2) Then
                al = .Item(ky1)
                data(al, 3) = data(al, 3) + 1
                .Item(ky2) = Null
            End If
        Next i
    End With

    With Sheets("Sayfa1")
        Range("F2:H" & .Cells(Rows.Count, 6).End(3).Row).ClearContents
        Range("F2:H" & say + 1).Value = data
    End With

End Sub

Aradığım kod buydu. Emeğinize sağlık hocam. Kod içerisinde salise leri dahil etmiyordu, onu ekledim sadece ve tam da istediğim gibi çalışıyor. Bunu python a dönüştürüp kullanıyorum.

Bu vesileyle tüm excel.web.tr ailesinin bayramını kutluyorum.

 

[cedi007]

Sub test()
    Dim lst, i, say, data, ky1, ky2, al

    With Sheets("Sayfa1")
        lst = .Range("A2:C" & .Cells(Rows.Count, 1).End(3).Row).Value
    End With

    ReDim data(1 To UBound(lst), 1 To 3)

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            ky1 = lst(i, 1) & "|" & lst(i, 3)
            ky2 = ky1 & "|" & Format(lst(i, 2), "ddmmyyyy hhmm")
            If Not .exists(ky1) Then
                say = say + 1
                .Item(ky1) = say
                data(say, 1) = lst(i, 1)
                data(say, 2) = lst(i, 3)
                data(say, 3) = 0
            End If
            If Not .exists(ky2) Then
                al = .Item(ky1)
                data(al, 3) = data(al, 3) + 1
                .Item(ky2) = Null
            End If
        Next i
    End With

    With Sheets("Sayfa1")
        Range("F2:H" & .Cells(Rows.Count, 6).End(3).Row).ClearContents
        Range("F2:H" & say + 1).Value = data
    End With

End Sub

Hocam selamlar,

Burada ayrıca bir güncelleme yapmak istiyorum. Detaylarını dosya içerisinde belirttim anlaşılır olması açısından. Bu şekilde revize etmemiz mümkün müdür?

 

[cedi007]

Hocam selamlar,

Burada ayrıca bir güncelleme yapmak istiyorum. Detaylarını dosya içerisinde belirttim anlaşılır olması açısından. Bu şekilde revize etmemiz mümkün müdür?

Acaba bu konuda yardımcı olabilecek birileri olur mu? Teşekkürler.