Benzersizler için değişik bir istek.

[yeniyetme]

Yaklaşık bir aydır forumumuzdaki bütün benzersiz örneklerini inceledim diyebilirim. Takıldığım yerlerde değerli forum üyelerinden gerekli yardımı da gördüm. Benim istediğim gibi bir örnek olmadığı için (veya mantığını tam kavrayamadığım için) yeni konu açmak mecburiyetinde kaldım...

Soru şu şekilde A sutunundaki ve b sutunundaki benzersiz olan kayıtları bul c sutunundaki toplamını al sayfa ikiye aktar. Verdiğim çok basit bir örnekle ne demek istediğimi anlayacağınızı düşünüyorum.

 

[Ali]

Ekte bir örnek yaptım umarım işiniz görür.

 

[yeniyetme]

Makrolarla uyarlayabilirmiyiz bu formulleri.

 

[yeniyetme]

Ali bey bu arada teşekkür etmeyi unutmuşum. kusura bakmayın
Yaptığınız formuller işimi görüyor ama ben programımın tamamını makro ile yazmak istiyorum. İlginize teşekkür ederim.

 

[Ferhat Pazarçevirdi]

Aşağıdaki gibi bir kod yazılabilir ... Örnek dosyayı inceleyiniz...

Option Explicit
Sub Benzersizleri_Listele()
    
    Dim col As New Collection
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim y As Integer
    Dim arr() As Variant
    Dim hcr As Range
    
    Sheets("Sayfa2").Range("A1:B" & Sheets("Sayfa2").Cells(65536, 1).End(xlUp).Row).ClearContents
    
    On Error Resume Next
    
    y = 1
    
     For Each hcr In Sheets("Sayfa1").Range("A7:B" & Sheets("Sayfa1").Cells(65536, 1).End(xlUp).Row).Cells
        
        col.Add CStr(hcr), CStr(hcr)
            
        If Err.Number = 0 Then
            x = x + 1
            ReDim Preserve arr(1 To 2, 1 To x)
            arr(1, x) = CStr(hcr.Value)
            arr(2, x) = Sheets("Sayfa1").Cells(hcr.Row, 3)
        Else
            For j = 1 To UBound(arr, 2)
                If arr(1, j) = CStr(hcr.Value) Then
                    Exit For
                End If
            Next j
            
            arr(2, j) = arr(2, j) + Sheets("Sayfa1").Cells(hcr.Row, 3)
        
        End If
        
        Err.Number = 0
        
    Next
    
    Sheets("Sayfa2").Range("A1").Resize(UBound(arr, 2), UBound(arr, 1)) = Application.WorksheetFunction.Transpose(arr)
    On Error GoTo 0
End Sub

 

[yeniyetme]

Ferhat hocam çok teşekkür ederim mükemmel bir makro .

Yalnız şöyle bir sorunum var b sutununda boş veri varsa bunu benzersizlere atmasa böyle bir değişiklik yapılabilirmi acaba. Örnek olarak a sutununda 5 veri varken b sutununda 3 veri olduğu zaman b sutunundaki boş hücreleride benzersizlere atıyor ve toplamını alıyor.
Bu kodda değişiklik yapılabilir mi ?

 

[Ali]

Sub listele()
For a = 2 To Cells(65536, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, 1)) = 1 Then
c = c + 1
Sheets("Sayfa2").Cells(c, 1) = Cells(a, 1).Value
End If
Next
For b = 2 To Cells(65536, 2).End(xlUp).Row
If WorksheetFunction.CountIf(Range("b2:b" & b), Cells(b, 2)) = 1 Then
t = Sheets("Sayfa2").Cells(65536, 1).End(xlUp).Row
t = t + 1
Sheets("Sayfa2").Cells(t, 1) = Cells(b, 2).Value
End If
Next
Sheets("Sayfa2").Select
For a = Cells(65536, 1).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then Rows(a).Delete
Next
toplamal
End Sub
Sub toplamal()
satır = Sheets("Sayfa2").Cells(65536, 1).End(xlUp).Row
For a = 1 To satır
isim = Sheets("Sayfa2").Cells(a, 1).Value
Sheets("Sayfa2").Cells(a, 2) = Evaluate("SUMPRODUCT((Sayfa1!a2:a55000=""" & isim & """)*(Sayfa1!c2:c55000))+SUMPRODUCT((Sayfa1!b2:b55000=""" & isim & """)*(Sayfa1!c2:c55000))")
Next
End Sub

Aşağıdaki örneği incelermisiniz.

 

[yeniyetme]

Ali hocam süpersiniz ya hızır gibi yetiştiniz. Örnek programı inceledim görevini fazlasıyla yapıyor. Şimdi kendi programıma entegre edicem.
Saygılar sevgiler sunuyorum...