[Çözüldü] Aynı gün yapılan işlem adedi birden fazla ise tek sayma

[drejan62]

Merhabalar,
Sayfa1 de A sütununda tarih B sütununda müşteri numarası var.
Sayfa2 A sütununda  ise Sayfa1 de yer alan müşteri numaraları var.Sayfa2 de B sütununa girilecek bir formül ile Sayfa2 A sütünündaki Müşterinin Sayfa1 de  bulunan tüm veriler içinde kaç defa yazıldığını bulmak istiyor ama aynı tarihte birden fazla aynı müşteri numarası var ise bunu tek işlem olarak almasını istiyorum.
Teşekkürler
Örnek:
Sayfa1
ASütunu---------B Sütunu
Tarih-------------Numara
01.01.2010 ---- 1234
01.01.2010------234
01.01.2010------1234
02.01.2010------234
02.01.2010------1234

Sayfa1
ASütunu---------B Sütunu
Numara----------Adet
1234--------------2 (normalde sayfa1 de 1234 numralı müşteri 3 adet olmasına rağmen aynı tarihteki işlemi tek aldığımız için sonuç 2 çıktı)
234----------------2

[Orion1]

Formül biraz bu duruma ,bana biraz uygun gelmedi.
Kod ile olsa yapardım.

[drejan62]

Formül biraz bu duruma ,bana biraz uygun gelmedi.
Kod ile olsa yapardım.

Üstat çözelim de kodla çözelim hepsi uyar bana
Teşekkür ederim

[Orion1]

Üstat çözelim de kodla çözelim hepsi uyar bana
Teşekkür ederim

Örnek dosya ekleyiniz.

[drejan62]

Ekledim Üstad.

Yalnız yanıt gönderirken yeni konu başlat diyor yazdıklarım boşa girdiyor 

[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[Orion1]

Dosyanız ektedir.:cool:

Kod: [Seç]

Sub bul_59()
Dim z As Object, k As Range, adr As String, say As Long
Dim sat As Long, i As Long, sh As Worksheet
Sheets("Sayfa1").Select
Range("B2:B65536").Clear
Set sh = Sheets("Sayfa2")
sat = Cells(65536, "A").End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To sat
    Set z = CreateObject("Scripting.Dictionary")
     Set k = sh.Range("D2:D65536").Find(Cells(i, "A").Value, , xlValues, xlWhole)
     If Not k Is Nothing Then
        adr = k.Address
        Do
            If Not z.exists(k.Offset(0, -3).Value) Then
                z.Add k.Offset(0, -3).Value, Nothing
                say = say + 1
            End If
            Set k = sh.Range("D2:D65536").FindNext(k)
        Loop While Not k Is Nothing And k.Address <> adr
    End If
    Cells(i, "B").Value = say
    say = 0
    Set z = Nothing
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
     
End Sub

[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[drejan62]

Teşekkürler Üstat

[Orion1]

Teşekkürler Üstat

Rica.