Soru Veri Sayfasındaki verilerin Tekrar Sayısını İcmal Sayfasına İşleme

[TURKOLOG]

Herkese Merhaba
Veri Sayfasında B2 den itibaren benzersiz mükerrer siciller var karşılarında da görev yerleri var

Veri Sayfasında bulunan B2 den itibaren yazılan siciller İcmal sayfasında b4ten itibaren mükerrer olandan yazılı

Yapılmak istenen
Veri Sayfasındaki siciller ile e sütunundaki görev yerleri sayılacak ve icmal sayfasında ilgili sicilin olduğu satir ve sutuna hesaplanan tekrar sayisi yazılacak

Yanı veri sayfasında
950000 sicili 130 da kaç defa yazılmış ise
Icmal sayfası 130 'ün altına hesaplanıp yazılacak

950000 sicili 131 de kaç defa yazılmış ise
Icmal sayfası 131 'in altına hesaplanıp yazılacak
Böyle her sicil için devam edecek

Yardımcı olabilecek olan varsa çok sevinirim .

 

[bmutlu966]

Sanınırm bu şekilde istiyorsunuz.

 

[veyselemre]

Sub test()
    Dim rng As Range, veri, i%, sicil, yer, sat, sut
    
    With Sheets("Veri")
        veri = .Range("B2:E" & .Cells(rows.count, "B").End(3).row).Value
    End With
    
    With Sheets("İCMAL")
        Set rng = .Range("A3:N" & .Cells(rows.count, "A").End(3).row)
        rng.Offset(1, 3).ClearContents
    End With

    With CreateObject("Scripting.Dictionary")
        For i = 2 To rng.rows.count
            .Item("r_" & rng.Cells(i, 1).Value) = i
        Next i
 
        For i = 3 To rng.columns.count
            .Item("c_" & rng.Cells(1, i).Value) = i
        Next i

        For i = 1 To UBound(veri)
            sicil = "r_" & veri(i, 1)
            yer = "c_" & veri(i, 4)
            If .Exists(sicil) Then
                sat = .Item(sicil)
            Else
                MsgBox veri(i, 1) & vbCr & "Sicil nolu personele ait İCMAL sayfasında bilgi yoktur.", vbCritical, "UYARI!"
                Exit Sub
            End If
            If .Exists(yer) Then
                sut = .Item(yer)
            Else
                MsgBox veri(i, 4) & vbCr & "Görev yerine ait İCMAL sayfasında bilgi yoktur.", vbCritical, "UYARI!"
                Exit Sub
            End If
            rng.Cells(sat, sut).Value = Val(rng.Cells(sat, sut).Value) + 1
        Next i
    
    End With
    MsgBox "İşlem tamamlanmıştır.", vbInformation

End Sub

 

[TURKOLOG]

Sub test()
    Dim rng As Range, veri, i%, sicil, yer, sat, sut
   
    With Sheets("Veri")
        veri = .Range("B2:E" & .Cells(rows.count, "B").End(3).row).Value
    End With
   
    With Sheets("İCMAL")
        Set rng = .Range("A3:N" & .Cells(rows.count, "A").End(3).row)
        rng.Offset(1, 3).ClearContents
    End With

    With CreateObject("Scripting.Dictionary")
        For i = 2 To rng.rows.count
            .Item("r_" & rng.Cells(i, 1).Value) = i
        Next i

        For i = 3 To rng.columns.count
            .Item("c_" & rng.Cells(1, i).Value) = i
        Next i

        For i = 1 To UBound(veri)
            sicil = "r_" & veri(i, 1)
            yer = "c_" & veri(i, 4)
            If .Exists(sicil) Then
                sat = .Item(sicil)
            Else
                MsgBox veri(i, 1) & vbCr & "Sicil nolu personele ait İCMAL sayfasında bilgi yoktur.", vbCritical, "UYARI!"
                Exit Sub
            End If
            If .Exists(yer) Then
                sut = .Item(yer)
            Else
                MsgBox veri(i, 4) & vbCr & "Görev yerine ait İCMAL sayfasında bilgi yoktur.", vbCritical, "UYARI!"
                Exit Sub
            End If
            rng.Cells(sat, sut).Value = Val(rng.Cells(sat, sut).Value) + 1
        Next i
   
    End With
    MsgBox "İşlem tamamlanmıştır.", vbInformation

End Sub

Veysel Hocam elinize emeğinize sağlık .