Need COUNTIF formula to be converted as a VBA code.

[motilulla]

Hello,

Column "D" contains mix data, and unique values in the column "G".
Result count of unique values column "G", respect column "D" is shown in the column "H"

I am using the below "COUNTIF" formula in the cell H6 via VBA to fill the range down to H6 till end. But need a VBA code for faster calculation please help?

Sub COUNTIF()
Range("H6:H48696").Formula = "=COUNTIF($D$6:$D$4108,$G6)"
End Sub

For more detail the image is attached here.

Thank you all.

I am using Excel 2000

Regards,
Moti

 

[kweaver]

If you use XL2BB anyone trying to help you won't have to retype your sample data.

Try this on limited data (change column I to H after testing):

Sub dCount()
Dim lrg As Long, lrd As Long, i As Long, cr As Long
lrg = Cells(Rows.Count, "G").End(xlUp).Row
lrd = Cells(Rows.Count, "D").End(xlUp).Row

For i = 6 To lrg
 cr = WorksheetFunction.CountIf(Range("D6:D" & lrd), Cells(i, "G"))
 Cells(i, "I") = cr
Next i
 
End Sub

Book5
	D	E	F	G	H	I
6	71|122|300			61|122|300	0	0
7	71|122|300			71|122|300	2	2
8	69|72|310			79|127|309	0	0
9	69|72|310			69|72|310	4	4
10	69|72|310
11	69|72|310
Sheet5

Cell Formulas
Range	Formula
H6:H9	H6	=COUNTIF($D$6:$D$11,G6)

 

[motilulla]

If you use XL2BB anyone trying to help you won't have to retype your sample data.

Try this on limited data (change column I to H after testing):

Sub dCount()
Dim lrg As Long, lrd As Long, i As Long, cr As Long
lrg = Cells(Rows.Count, "G").End(xlUp).Row
lrd = Cells(Rows.Count, "D").End(xlUp).Row

For i = 6 To lrg
 cr = WorksheetFunction.CountIf(Range("D6:D" & lrd), Cells(i, "G"))
 Cells(i, "I") = cr
Next i
 
End Sub

Book5
	D	E	F	G	H	I
6	71|122|300			61|122|300	0	0
7	71|122|300			71|122|300	2	2
8	69|72|310			79|127|309	0	0
9	69|72|310			69|72|310	4	4
10	69|72|310
11	69|72|310
Sheet5

Cell Formulas
Range	Formula
H6:H9	H6	=COUNTIF($D$6:$D$11,G6)

kweaver, I run your macro it is taking more time then what I got, I think but not sure VBA "With CreateObject("scripting.dictionary")" are more faster would you take a look please.

I appreciate your help

Note: regarding as far as I know it cannot be used with version 2000.

Kind Regards
Moti

 

[kweaver]

I suspected that using COUNTIF in the VBA code would NOT improve the performance much, if at all, since it was calling the function that was the issue.

 

[motilulla]

I suspected that using COUNTIF in the VBA code would NOT improve the performance much, if at all, since it was calling the function that was the issue.

kweaver, ok, any replacement with another formula, can improve the performance? if yes please suggest.

Kind Regards
Moti

 

[kweaver]

I don't understand scripting.dictionary very well, so I'm not the person to help using that. I'm sure someone else will reply with a good and fast solution.

 

[Alex Blakenburg]

If you had made @kweaver aware of the code that you already from had @Fluff from a very similar previous question, he would most likely have been able to help you.

Here is Fluff's code modified for this specific scenario.

I have commented the changes I made.
For some reason your data in this post doesn't align with your previous data (slightly different columns although same rows).

Sub Count_Unique_Values()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long
 
   Ary = Range("D6:D" & Range("D" & Rows.Count).End(xlUp).Row).Value2       'xxx Changed from C:F to D:D
   Nary = Range("G6", Range("G" & Rows.Count).End(xlUp)).Resize(, 2).Value2 'xxx Changed from I to G
 
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         .Item(Ary(r, 1)) = .Item(Ary(r, 1)) + 1                            'xxx Changed to just sum 1 (effectively a count)
      Next r
      For r = 1 To UBound(Nary)
         If .Exists(Nary(r, 1)) Then Nary(r, 2) = .Item(Nary(r, 1)) Else Nary(r, 2) = 0
      Next r
   End With
   Range("G6").Resize(UBound(Nary), 2).Value = Nary                         'xxx Changed from I to G
End Sub

 

[motilulla]

If you had made @kweaver aware of the code that you already from had @Fluff from a very similar previous question, he would most likely have been able to help you.

Hello Alex Blakenburg,

I apologise did not thought because this was "countif" and other were "Sumproduct" thank you for pointing out next time I will add the reference.

Here is Fluff's code modified for this specific scenario.

I have commented the changes I made.
For some reason your data in this post doesn't align with your previous data (slightly different columns although same rows).

I do appreciate your help it worked but I have an issue while changing the result column G2 to for example M2..."I am getting in M2 unique data duplicating column G" and result in the N2 i tried to modified but cannot got it work.

Please can you take a look?

Kind Regards,
Moti

 

[Alex Blakenburg]

Are you able to provide an xl2bb ? With the data and an example of the expected result.

Column D is the source data. If you don't change that you will get the same results.

 

[motilulla]

Are you able to provide an xl2bb ? With the data and an example of the expected result.

Column D is the source data. If you don't change that you will get the same results.

Hello Alex Blakenburg,

Regarding xl2bb, as far as I know it cannot use with version 2000. So far I have attached 2 images may help.

Image-A, if I run your code #post7 code getting results correct in the column H no problem.

Image-B, when I change result range in the VBA as below

This

Range("G6").Resize(UBound(Nary), 2).Value = Nary

To this

Range("I6").Resize(UBound(Nary), 2).Value = Nary

You can see the Image-B; I get result in Col "J" and in the Col "I" duplicated of Col "G"

Hope this help

Kind Regards,
Moti