Veri toplama

[ASLAN7410]

Merhaba hayırlı geceler.


Ekte gönderdiğim Sayfa1'deki B sütunundaki telefon numaralarının karşısındaki şahıslara ait görüşme sayılarını Sayfa2'ye toplamak istiyorum.

Formüllerle yapmaya çalıştım ancak veri çok olduğu için sayfa kilitleniyor.

Makro ile yardımcı olur musunuz?

 

[Orion1]

Dosyanız ektedir.

DOSYAYI İNDİR

Option Base 1
Sub benzersiz59()
Dim z As Object, sonsat As Long, sh As Worksheet
Dim n As Long, myarr(), liste(), i As Long
Sheets("Sayfa2").Select
Range("A2:C" & Rows.Count).ClearContents
Set sh = Sheets("Sayfa1")
sonsat = sh.Cells(Rows.Count, "B").End(xlUp).Row
liste = sh.Range("B2:D" & sonsat).Value
ReDim myarr(1 To 3, 1 To UBound(liste))
Set z = CreateObject("scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        n = n + 1
        z.Add liste(i, 1), n
        myarr(1, n) = liste(i, 1)
        myarr(3, n) = liste(i, 3)
    End If
    myarr(2, z.Item(liste(i, 1))) = myarr(2, z.Item(liste(i, 1))) + liste(i, 2)
Next i
Erase liste: Set sh = Nothing
Application.ScreenUpdating = False
If z.Count > 0 Then
    ReDim Preserve myarr(1 To 3, 1 To z.Count)
    Range("A2").Resize(z.Count, 3) = Application.Transpose(myarr)
    Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row).Sort key1:=Range("C2"), _
            order1:=xlAscending, key2:=Range("B2"), order2:=xlDescending
End If
Erase myarr: Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[ASLAN7410]

Sayın Evren Bey ilginiz için çok teşekkür ederim, tam istediğim gibi oldu, Allah razı olsun.

Hayırlı çalışmalar, hayırlı geceler diliyorum.

 

[Orion1]

Sayın Evren Bey ilginiz için çok teşekkür ederim, tam istediğim gibi oldu, Allah razı olsun.

Hayırlı çalışmalar, hayırlı geceler diliyorum.

Rica ederim.
İyi çalışmalar.

 

[ASLAN7410]

Sayın Evren Bey sizi tekrar rahatsız ediyorum.
Hayırlı geceler.

Daha önceden yazmış olduğunuz kod hatasız çalışıyor.

Ancak önceden istediğim bilgi eksikliğinden dolayı
işlemlerimi yaparken hesaplamalar yanlış çıkıyor, kusura bakmayın.

Yapmak istediğim yeni sayfayı ekledim.

Evren Bey yardımcı olur musunuz?

 

[Ziynettin]

Bu kodu da kullanabilirsiniz.

Option Explicit
Sub İsim_Telefon_Benzersiz_Toplam()
Dim a(), b(), d As Object
Dim i As Long, Say As Long, Krt As Variant

Sheets("Sayfa1").Select
Set d = CreateObject("Scripting.Dictionary")
a = Range("A2:F" & Cells(Rows.Count, 2).End(3).Row)

ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To UBound(a)
    Krt = a(i, 2) & a(i, 4)
    If Not d.exists(Krt) Then
        Say = Say + 1
        d.Add Krt, Say
        b(Say, 1) = a(i, 1)
        b(Say, 2) = a(i, 2)
        b(Say, 4) = a(i, 4)
        b(Say, 5) = a(i, 5)
        b(Say, 6) = a(i, 6)
    End If
    b(d(Krt), 3) = b(d(Krt), 3) + CDbl(a(i, 3))
Next i

With Sheets("Sayfa2")
    .Range("A2:F" & Rows.Count).ClearContents
    If Say > 0 Then
        .Range("A2").Resize(Say, UBound(a, 2)) = b
        .Range("B2").Resize(Say).NumberFormat = "(###) ### ## ##"
    End If
End With
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[ASLAN7410]

Sayın Ziynettin Bey ilginiz için çok teşekkür ederim, gece çalıştığım için bilgisayar başına yeni geçebildim.

Kodları kendi orijinal sayfamda uygulayıp bilgi vereceğim.

 

[ASLAN7410]

Sayın Ziynettin Bey ilginiz için çok teşekkür ederim ellerinize sağlık, tam istediğim gibi çalışıyor.

Allah razı olsun, hayırlı geceler hayırlı çalışmalar diliyorum.