VBA loop a countif function in a moving range

[snoom82]

Hi,
I am currently using a formula to count the number of similar cells through a moving range, however due to the number of rows, the calculation is too long. I was thinking abount doing the same via VBA however I am not good with looping and conditions in VBA.

The current formula I am using is the following:

=count.if($C2:$C$50000,C2)-1

This would be in cell X2, for the following cell I want to make sure that the first row in the range is incremented but the last row remains the same (therefore C3:C50000)

I have worked out the vba code for the formula however when it comes to looping it, I am stuck:

Sub CountCells()
    Range("X3") = WorksheetFunction.CountIf(Range("C3:C50000"), Range("C3"))
End Sub

So only the cell C50000 would remain as a fixed cell, the others would get incremented by 1 until it reaches the last designated row, 50000

Any help would be greatly appreciated!

 

[NdNoviceHlp]

Hi *snoom82 and Welcome to the Board! Seems like this code would work. HTH. Dave

Sub CountCells()
Dim Cnt As Integer
With ActiveSheet
For Cnt = 2 To 5000
.Range("X" & Cnt) = Application.WorksheetFunction.CountIf(.Range("C" & Cnt & ":C50000"), .Range("C" & Cnt))
Next Cnt
End With
End Sub

 

[Cubist]

Working with large range of data, consider using array for better performance.

Sub CumulativeCountOfDuplicates()
    Dim ws As Worksheet
    Dim dict As Object
    Dim lastRow As Long
    Dim dataRange As Range
    Dim data As Variant
    Dim counts() As Long
    Dim i As Long
    Dim currentValue As Variant
   
    Set dict = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Sheets("Sheet1") 'change sheet name as needed
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    Set dataRange = ws.Range("C2:C" & lastRow)
    data = dataRange.Value
    ReDim counts(1 To UBound(data, 1), 1 To 1)
   
    For i = 1 To UBound(data, 1)
        currentValue = data(i, 1)
        If dict.exists(currentValue) Then
            counts(i, 1) = dict(currentValue) + 1
            dict(currentValue) = counts(i, 1)
        Else
            dict(currentValue) = 1
            counts(i, 1) = 0
        End If
    Next i
   
    ws.Range("X2").Value = counts
End Sub

 

[Cubist]

NdNoviceHlp, This needs to stay static.

.Range("X" & Cnt).Value = Application.WorksheetFunction.CountIf(.Range("C2:C50000"), .Range("C" & Cnt).Value)

 

[NdNoviceHlp]

Hmmm..... "the first row in the range is incremented but the last row remains the same (therefore C3:C50000)" Dave

 

[Cubist]

NdNoviceHlp I've misread the problem. Apologies.
snoom82 ,I've revised my above code.

Sub CumulativeCountOfDuplicates2()
    Dim lastRow As Long
    Dim dataRange As Range
    Dim dataArr As Variant
    Dim countsDict As Object
    Dim cellValue As Variant
    Dim outputArr() As Variant
    Dim i As Long
    Set countsDict = CreateObject("Scripting.Dictionary")

    With ActiveSheet
        lastRow = .Cells(.Rows.count, "C").End(xlUp).Row
        Set dataRange = .Range("C2:C" & lastRow)
        dataArr = dataRange.Value
        ReDim outputArr(1 To lastRow, 1 To 1)
        For i = LBound(dataArr, 1) To UBound(dataArr, 1)
            Set dataRange = .Range("C" & (i + 1) & ":C" & lastRow)
            cellValue = dataArr(i, 1)
            Set countsDict = CreateObject("Scripting.Dictionary")
            If Not countsDict.Exists(cellValue) Then
                countsDict(cellValue) = Application.WorksheetFunction.CountIf(dataRange, cellValue)
            End If
            outputArr(i, 1) = countsDict(cellValue)
        Next i
        .Range("X2").Resize(UBound(outputArr, 1), 1).Value = outputArr
    End With
End Sub

 

[Cubist]

I've revised my prior code tested this on 50,000 rows. My average run time is 0.25 seconds

Sub CountInitialAndDecrement3()
    Dim t As Double: t = Timer
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dataArr As Variant
    Dim resultArr() As Variant
    Dim i As Long
    Dim key As Variant
    Set ws = ThisWorkbook.Sheets("Sheet1") 'change sheet to suit
    lastRow = ws.Cells(ws.Rows.count, "C").End(xlUp).Row

    dataArr = ws.Range("C2:C" & lastRow).value
    For i = 1 To UBound(dataArr, 1)
        If Not IsEmpty(dataArr(i, 1)) Then
            If Not dict.exists(dataArr(i, 1)) Then
                dict.Add dataArr(i, 1), 1
            Else
                dict(dataArr(i, 1)) = dict(dataArr(i, 1)) + 1
            End If
        End If
    Next i
    ReDim resultArr(1 To UBound(dataArr, 1), 1 To 1)
    For i = 1 To UBound(dataArr, 1)
        If Not IsEmpty(dataArr(i, 1)) Then
            key = dataArr(i, 1)
            If dict(key) > 0 Then
                resultArr(i, 1) = dict(key)
                dict(key) = dict(key) - 1
            Else
                resultArr(i, 1) = 0
            End If
        End If
    Next i
    ws.Range("X2").Resize(UBound(resultArr, 1), UBound(resultArr, 2)).value = resultArr
    Set dict = Nothing
   
    MsgBox Round(Timer - t, 2) & " seconds"
End Sub

 

[snoom82]

Thank you so much @Cubist that works perfectly, average time of 0,20 seconds!

 

[Cubist]

You're welcome. Thanks for the feedback. Cheers.