• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Count the Records

Deepak

Excel Ninja
Hi all,

Hope, You are doing good!

Your lovable solution are welcomed in attached file where we need to count the unique records based on the following condition..

  1. Each count should only be max 100.
  2. Either Each doc [col C] should be 100 or doc [col C] & FN&SN [col A&B] combination should be 100.

Note:
We can't manipulate data like as sorting etc, it would be as it is.
Each count should not be more then 100
Both Formula/VBA approach are valid.
 

Attachments

  • DB_sample.xlsx
    103.2 KB · Views: 21
Not sure if I understood all the criteria correctly. But see attached.
 

Attachments

  • DB_Test.xlsx
    99.7 KB · Views: 4
Hmm, so you want duplicates allocated to different grouping as well? 319 is count of duplicates and not unique records.
 
No!

upload_2016-3-17_19-14-2.png

These are same & also assigned same count value.

Let me re-explain. You may use new approach rather then mine based on below condition.

Count either col C & combination of col A,B,C where as each count should be max 100. As soon as it reach it 100, now it's count assigned value would be jumped up to next group.
 
Hmm, it's a difficult one. I've got to a point using "Scripting.Dictionary".

But will need additional allocation logic (left over duplicates)... and not very flexible. I can't help but think there's better way to do this.

I might do one of things below.
1) Allocate duplicate values to separate containers before true unique values
2) Use another set of .Exists to look in each container and swap out...

I'll give it another go tomorrow night.
 

Attachments

  • DB_Test.xlsb
    44.8 KB · Views: 9
Hmm, yes. That would cause issue.

Since logic used to make it dynamic is using count of records/100.

If record is less than 100 and has duplicates. It will not have enough container.

It will also cause issue, if there are more duplicates than containers available (for example 1 record has 15 duplicates, but total record count is 1350).

Let me think a bit more on the initial logic. Other than it should work fine.
 
@Deepak

How do you want it treated in case above?
1. Change container size from 100 to smaller one
2. Add additional containers of same size (Ex. If there is record with 15 duplicates, and record count is less than 1401, it will create additional containers)

Option 1 will increase number of containers, but will fill container before moving on to next (albeit smaller size limit for containers)

Option 2 will keep container size limit constant. However, will have containers not filled to capacity before reaching the last one.
 
I think! Second would be the best! Meanwhile for <100 data, I may also use the formula approach without any issue!
 
Not really sure though....
Code:
Sub test()
    Dim a, i As Long, n As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With Cells(1).CurrentRegion.Resize(, 4)
        a = .Value: n = 1
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 3)) Then
                    If Not dic.exists(n) Then
                        Set dic(n) = CreateObject("Scripting.Dictionary")
                    End If
                    If dic(n)(0) = 100 Then
                        Do
                            n = n + 1
                            If Not dic.exists(n) Then
                                Set dic(n) = CreateObject("Scripting.Dictionary")
                                Exit Do
                            Else
                                If dic(n)(0) < 99 Then Exit Do
                            End If
                        Loop
                    End If
                    .Item(a(i, 3)) = n
                    dic(n)(0) = dic(n)(0) + 1: a(i, 4) = n
                Else
                    .Item(a(i, 3)) = .Item(a(i, 3)) + 1
                    If Not dic.exists(.Item(a(i, 3))) Then
                        Set dic(.Item(a(i, 3))) = CreateObject("Scripting.Dictionary")
                    End If
                    dic(.Item(a(i, 3)))(0) = dic(.Item(a(i, 3)))(0) + 1
                    If dic(.Item(a(i, 3)))(0) = 100 Then
                        Do
                            .Item(a(i, 3)) = .Item(a(i, 3)) + 1
                            If Not dic.exists(.Item(a(i, 3))) Then
                                Set dic(.Item(a(i, 3))) = CreateObject("Scripting.Dictionary")
                                Exit Do
                            Else
                                If dic(.Item(a(i, 3)))(0) < 100 Then Exit Do
                            End If
                        Loop
                    End If
                    dic(.Item(a(i, 3)))(0) = dic(.Item(a(i, 3)))(0) + 1: a(i, 4) = .Item(a(i, 3))
                End If
            Next
        End With
        .Value = a
    End With
End Sub
 
Ok this works (tested for record count < 100).

Code:
Sub Test()
    Const MAXVAL = 100
    Dim Buckets() As Object
    Dim lRow As Long, c As Long, x As Long, maxDup As Long
    Dim cel As Range, cRange As Range
    Dim i As Integer, dCount As Integer
    Dim fVal As String

    lRow = Range("A" & Rows.Count).End(xlUp).Row
    NumberofBuckets = (lRow - 1) \ MAXVAL + 1
    Set cRange = Range("C2:C" & lRow)

    For Each cel In cRange
        maxDup = Application.WorksheetFunction.Max(maxDup, Application.WorksheetFunction.CountIf(cRange, cel))
    Next cel
   
    If NumberofBuckets < maxDup Then
        NumberofBuckets = maxDup
    End If
   
   
    ReDim Buckets(1 To NumberofBuckets)

    For i = 1 To NumberofBuckets
        Set Buckets(i) = CreateObject("Scripting.Dictionary")
    Next


c = 2
Do Until c = lRow + 1
    Set cel = Cells(c, 3)
    fVal = cel.Value
    dCount = Application.WorksheetFunction.CountIf(cRange, fVal)
    For i = 1 To NumberofBuckets
        If Not Buckets(i).Exists(CStr(fVal)) And Buckets(i).Count < 100 Then
            If dCount > 1 Then
                Buckets(i).Add CStr(fVal), fVal
                cel.Offset(0, 1).Value = i
                Exit For
            End If
        End If
    Next
c = c + 1
Loop
   
   
c = 2
Do Until c = lRow + 1
        Set cel = Cells(c, 3)
        For i = 1 To NumberofBuckets
            If Not Buckets(i).Exists(CStr(cel.Value)) And Buckets(i).Count < 100 Then
                If cel.Offset(0, 1).Value < 1 Then
                    Buckets(i).Add CStr(cel.Value), cel.Value
                    cel.Offset(0, 1).Value = i
                    Exit For
                End If
            End If
        Next
c = c + 1
Loop
End Sub
 

Attachments

  • DB_Test2 (1).xlsb
    41.4 KB · Views: 2
No problem. It was interesting learning experience, had to learn methods I typically don't use.

Array, Dictionary, Do loops ;) I've avoided array like a plague till now, but this made me re-think it.
 
Back
Top