benzersiz kayıt için 2 sutun sorunu kodları verdim.

[yeniyetme]

Sub HESAPLAma()
Dim SUT, S As Integer
S = 1
For SUT = 2 To Cells(65536, "b").End(3).Row
If Not WorksheetFunction.CountIf(Range("b2:b" & SUT), Cells(SUT, "b")) > 1 Then

S = S + 1
Cells(S, "m") = Cells(SUT, "b")
End If
Next
S = 1
For SUT = 2 To Cells(65536, "m").End(3).Row
S = S + 1
Cells(S, "n") = WorksheetFunction.SumIf(Range("b2:b65536"), Cells(SUT, "m"), Range("c2:c65536"))
Next
End Sub

bu makro b sutununa bakıyor benzersizleri m sutununa yazıyor
c sutunundaki rakamları toplayıp n sutununa yazıyor.

benim istediğim hem b sutununa baksın hem d sutununa benzersizleri yine m sutununa yazsın
c sutunundaki rakamları ve e sutunundaki rakamları toplayıp n sutununa yazsın


dizi tanımlama yapılarak yapılacağını biliyorum ama bir türlü yapamadım.
ilgilenirseniz çok sevinirim.

 

[Ferhat Pazarçevirdi]

Aşağıdaki gibi bir kod kullanabilirsiniz.

Option Explicit
Dim x As Integer
[COLOR=darkgreen]'-------------------------------[/COLOR]
Sub Hesapla()
    
    Dim sayac As Integer
    Dim arrV() As Variant
    Dim coll As New Collection
    
    Call Benzersiz(Range("B2:B" & Cells(65536, "B").End(xlUp).Row), arrV, coll)
    Call Benzersiz(Range("D2:D" & Cells(65536, "D").End(xlUp).Row), arrV, coll)
    
    Range("M2").Resize(UBound(arrV, 2), UBound(arrV, 1)) = Application.WorksheetFunction.Transpose(arrV)
    x = 0
    
End Sub
[COLOR=darkgreen]'-----------------------------------[/COLOR]
Sub Benzersiz(rg As Range, arr As Variant, col As Collection)
    
    Dim hcr As Range
    Dim j As Integer
   
    On Error Resume Next
    
    For Each hcr In rg.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) = hcr
            arr(2, x) = hcr.Offset(0, 1)
        Else
            For j = 1 To UBound(arr, 2)
                If hcr = arr(1, j) Then
                    arr(2, j) = arr(2, j) + hcr.Offset(0, 1)
                    Exit For
                End If
            Next j
            Err.Number = 0
        End If
    Next
        
    On Error GoTo 0
End Sub

 

[yeniyetme]

sn ferhat bey yazdığınız komut işimi görmedi. yazdığınız kodların toparlamaya çalıştım ama toparlayamadım. yorumda yapamıyorum. bunun için farklı bir örnek dosya gönderiyorum.
dosya ektedir ilgilenirseniz çok sevinirim...

 

[Ferhat Pazarçevirdi]

İlk mesajınızda bahsettiğiniz yapı ile gönderdiğiniz dosyadaki yapı bir değil. Tabi ki çalışmaz ...

İlk mesajınızda; B,C,D,E sütunlarında veri olduğunu ve bunların değerlendirmesini M ve N sütunlarına yazdırmak istediğiniz belirtmiştiniz? Öyle değil mi? Ben mi yanlış okudum yoksa Şimdi de, A,B,C,D sütunları ve F,G sütunları var ...

Kodunuzu aşağıdaki şekilde değiştiriniz veya örnek dosyayı inceleyiniz. Bir üstteki kodla değişiklikler kırmızı ile belirtilmiştir.

NOT : Veli ve Naci'yi iki defa yazıyor demeyin ... Hücredeki yazılış biçimini inceleyin.

Option Explicit
Dim x As Integer
'-------------------------------
Sub Hesapla()
    
    Dim sayac As Integer
    Dim arrV() As Variant
    Dim coll As New Collection
    
    Call Benzersiz(Range("[COLOR=red]A[/COLOR]2:[COLOR=red]A[/COLOR]" & Cells(65536, "[COLOR=red]A[/COLOR]").End(xlUp).Row), arrV, coll)
    Call Benzersiz(Range("[COLOR=red]C[/COLOR]2:[COLOR=red]C[/COLOR]" & Cells(65536, "[COLOR=red]C[/COLOR]").End(xlUp).Row), arrV, coll)
    
    Range("[COLOR=red]F[/COLOR]2").Resize(UBound(arrV, 2), UBound(arrV, 1)) = Application.WorksheetFunction.Transpose(arrV)
    x = 0
    
End Sub
'-----------------------------------
Sub Benzersiz(rg As Range, arr As Variant, col As Collection)
    
    Dim hcr As Range
    Dim j As Integer
   
    On Error Resume Next
    
    For Each hcr In rg.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) = hcr
            arr(2, x) = hcr.Offset(0, 1)
        Else
            For j = 1 To UBound(arr, 2)
                If hcr = arr(1, j) Then
                    arr(2, j) = arr(2, j) + hcr.Offset(0, 1)
                    Exit For
                End If
            Next j
            Err.Number = 0
        End If
    Next
        
    On Error GoTo 0
End Sub

 

[yeniyetme]

Verdiğiniz makro için teşekkür ederim işimi görüyor.
birşey daha soracağım ama cevap vermesenizde saygı duyarım

Call Benzersiz(Range("A2:A" & Cells(65536, "A").End(xlUp).Row), arrV, coll)
Call Benzersiz(Range("C2:C" & Cells(65536, "C").End(xlUp).Row), arrV, coll)

ben bu kodlarda e sutunu g sutununu .....bu kodun altına devam ederek yazabilirmiyim. evet veya hayır deyin yeterli kendinizi yormayın.
tekrar teşekkür ederim....

 

[Ferhat Pazarçevirdi]

Yok canım neden cevap vermeyelim

Evet, söylediğiniz genişlemeyi istediğiniz kadar yapabilirsiniz. Ama; aşağıdaki satırı da dikkate almalısınız.

    [COLOR=red]Range("F2").[/COLOR]Resize(UBound(arrV, 2), UBound(arrV, 1)) = Application.WorksheetFunction.Transpose(arrV)

Çünkü, bu satır toplanan verilerin yazdırılacağı ilk hücreyi belirliyor. E, G,, I, K gibi sütunları da ilave ettikten sonra, Range("F2") yazan yeri, örneğin Range("N2") yapın ki, N2 hücresinden aşağı doğru yazdırmaya başlasın.

Eğer bunu ayarlamazsanız, derlenen veriler, diğerlerini üzerine yazılır.

 

[yeniyetme]

Ferhat bey tuttuğunuz altın olsun.
çok teşekkür ederim........

sizin gibiler (melekler ) sayesinde makroyu öğreneceğiz galiba...