Need VBA, instead using formula

motilulla · Oct 8, 2018

Hello,

I got data in column D, is currently filled with 6500 rows, in the column F I do got unique list within 62000 rows, in the G4 entered formula =COUNTIF($D$4:$D$10000,F4) when i copy down to end 62000 rows it takes long tine to count and after i need to convert them in values it take back to much time

My request is it, do this task have any VBA solution

Book1

D

E

F

G

1

2

3

DATA

UNIQUE LIST

COUNT

4

1|0 = 0|1 = 1|1 = 1|0 = 0|1 = 1|0 = 0|1

0|0 = 0|0 = 0|0 = 0|1 = 0|2 = 0|2 = 0|2

0

5

1|0 = 0|2 = 0|1 = 2|0 = 0|2 = 2|0 = 0|0

0|0 = 0|0 = 0|0 = 0|1 = 0|2 = 0|2 = 1|1

0

6

1|0 = 0|0 = 2|0 = 0|2 = 2|0 = 0|0 = 2|0

0|1 = 0|0 = 1|0 = 0|0 = 1|1 = 1|0 = 2|0

1

7

1|0 = 0|1 = 0|1 = 1|0 = 1|0 = 0|1 = 0|1

0|0 = 0|0 = 0|0 = 0|1 = 0|2 = 1|1 = 0|2

0

8

1|0 = 1|0 = 1|0 = 1|0 = 0|0 = 1|0 = 1|0

0|0 = 0|0 = 0|0 = 0|1 = 0|2 = 1|1 = 1|1

0

9

2|0 = 1|0 = 0|0 = 1|0 = 1|0 = 0|1 = 1|1

0|0 = 0|0 = 0|0 = 0|1 = 0|2 = 1|1 = 2|0

0

10

1|1 = 0|0 = 0|1 = 2|0 = 1|0 = 0|0 = 0|1

0|0 = 0|0 = 0|0 = 0|1 = 0|2 = 2|0 = 0|2

0

11

1|0 = 2|0 = 0|0 = 0|0 = 0|0 = 1|0 = 0|0

0|1 = 0|0 = 0|2 = 0|2 = 0|0 = 0|0 = 1|1

1

12

1|0 = 1|0 = 0|1 = 0|1 = 0|0 = 1|1 = 1|1

0|0 = 0|0 = 0|0 = 0|1 = 0|2 = 2|0 = 2|0

0

13

1|1 = 1|0 = 1|0 = 0|0 = 0|0 = 1|0 = 1|0

0|0 = 0|0 = 0|0 = 0|1 = 1|1 = 0|2 = 0|2

0

14

0|0 = 0|0 = 0|0 = 2|0 = 1|0 = 0|0 = 1|1

0|0 = 0|0 = 0|0 = 0|1 = 1|1 = 0|2 = 1|1

0

15

0|1 = 0|1 = 1|0 = 0|1 = 1|1 = 0|0 = 1|0

0|0 = 0|0 = 0|0 = 0|1 = 1|1 = 0|2 = 2|0

0

16

1|0 = 1|0 = 0|1 = 2|0 = 1|0 = 0|0 = 1|0

0|0 = 0|0 = 0|0 = 0|1 = 1|1 = 1|1 = 0|2

0

17

1|0 = 1|0 = 0|1 = 0|0 = 0|2 = 1|0 = 0|0

0|0 = 0|0 = 0|0 = 0|1 = 1|1 = 1|1 = 1|1

0

18

0|0 = 1|0 = 0|0 = 0|0 = 1|0 = 0|0 = 0|0

0|0 = 0|0 = 0|0 = 0|1 = 1|1 = 1|1 = 2|0

0

19

1|0 = 1|1 = 0|0 = 0|1 = 1|0 = 0|1 = 2|0

0|0 = 1|0 = 1|0 = 0|0 = 0|0 = 1|0 = 0|0

1

20

0|0 = 1|0 = 1|0 = 1|0 = 1|0 = 0|0 = 0|0

0|0 = 0|0 = 0|0 = 0|1 = 1|1 = 2|0 = 1|1

0

21

0|0 = 0|0 = 1|0 = 1|1 = 0|0 = 0|0 = 0|1

0|0 = 0|0 = 0|0 = 0|1 = 1|1 = 2|0 = 2|0

0

22

0|0 = 0|0 = 0|0 = 0|0 = 0|0 = 1|1 = 1|0

0|0 = 0|0 = 0|0 = 0|1 = 2|0 = 0|2 = 0|2

0

23

0|1 = 0|1 = 0|0 = 0|0 = 0|0 = 1|0 = 0|0

0|0 = 0|0 = 0|0 = 0|1 = 2|0 = 0|2 = 1|1

0

24

0|0 = 1|0 = 0|0 = 0|0 = 0|0 = 0|0 = 0|1

0|0 = 0|0 = 0|0 = 0|1 = 2|0 = 0|2 = 2|0

0

25

2|0 = 1|0 = 0|0 = 1|0 = 0|1 = 1|0 = 0|0

0|0 = 0|0 = 0|0 = 0|1 = 2|0 = 1|1 = 0|2

0

26

1|1 = 0|0 = 0|1 = 0|0 = 0|0 = 2|0 = 1|0

0|0 = 0|0 = 0|0 = 0|1 = 2|0 = 1|1 = 1|1

0

27

1|0 = 0|2 = 0|0 = 0|1 = 2|0 = 0|0 = 1|0

0|0 = 0|0 = 0|0 = 0|1 = 2|0 = 1|1 = 2|0

0

28

0|1 = 2|0 = 0|0 = 2|0 = 1|0 = 0|0 = 0|0

0|0 = 0|0 = 0|0 = 0|1 = 2|0 = 2|0 = 0|2

0

29

1|0 = 0|1 = 0|1 = 0|0 = 0|1 = 0|0 = 1|0

0|0 = 0|0 = 0|0 = 0|1 = 2|0 = 2|0 = 1|1

0

30

0|0 = 1|0 = 0|2 = 0|1 = 1|0 = 1|0 = 1|0

0|0 = 0|0 = 0|0 = 0|1 = 2|0 = 2|0 = 2|0

0

31

0|1 = 1|0 = 1|0 = 1|0 = 0|0 = 0|0 = 0|0

0|0 = 0|0 = 0|0 = 0|2 = 0|1 = 0|2 = 0|2

0

32

1|0 = 0|0 = 0|0 = 0|1 = 1|1 = 1|0 = 2|0

0|0 = 0|0 = 0|0 = 0|2 = 0|1 = 0|2 = 1|1

0

33

0|1 = 0|0 = 1|0 = 0|0 = 1|1 = 1|0 = 2|0

0|0 = 0|0 = 0|0 = 0|2 = 0|1 = 0|2 = 2|0

0

34

1|0 = 0|0 = 1|0 = 0|1 = 0|0 = 1|0 = 2|0

0|0 = 0|0 = 0|0 = 0|2 = 0|1 = 1|1 = 0|2

0

35

1|1 = 0|0 = 1|0 = 1|0 = 1|0 = 0|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 0|1 = 1|1 = 1|1

0

36

1|0 = 1|1 = 1|0 = 0|0 = 0|0 = 0|1 = 1|0

0|0 = 2|0 = 1|0 = 0|0 = 2|0 = 1|1 = 0|0

1

37

1|0 = 2|0 = 1|0 = 0|0 = 1|0 = 0|2 = 0|0

0|0 = 0|0 = 0|0 = 0|2 = 0|1 = 2|0 = 0|2

0

38

1|0 = 1|0 = 1|1 = 0|0 = 1|0 = 1|0 = 0|1

0|0 = 0|0 = 0|0 = 0|2 = 0|1 = 2|0 = 1|1

0

39

1|0 = 0|0 = 1|0 = 2|0 = 0|1 = 0|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 0|1 = 2|0 = 2|0

0

40

0|1 = 0|0 = 0|0 = 1|0 = 2|0 = 1|0 = 0|2

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 0|1 = 0|2

0

41

1|0 = 0|0 = 0|0 = 0|0 = 0|1 = 0|2 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 0|1 = 1|1

0

42

1|1 = 1|0 = 1|0 = 0|0 = 2|0 = 2|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 0|1 = 2|0

0

43

1|1 = 0|0 = 1|0 = 0|1 = 0|0 = 0|0 = 0|1

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 0|2 = 0|1

0

44

1|0 = 1|0 = 0|0 = 0|0 = 0|0 = 1|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 0|2 = 1|0

0

45

2|0 = 0|0 = 1|0 = 1|1 = 0|0 = 0|0 = 2|0

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 1|0 = 0|2

0

46

0|0 = 1|0 = 1|0 = 0|0 = 0|0 = 1|0 = 0|0

2|0 = 0|0 = 1|0 = 0|0 = 0|0 = 0|0 = 0|0

1

47

2|0 = 0|0 = 1|0 = 0|0 = 0|0 = 0|0 = 0|0

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 1|0 = 2|0

0

48

0|0 = 1|0 = 0|0 = 0|0 = 0|1 = 1|0 = 0|0

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 1|1 = 0|1

0

49

0|0 = 0|0 = 1|0 = 1|0 = 1|1 = 2|0 = 2|0

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 1|1 = 1|0

0

50

0|0 = 0|0 = 0|1 = 2|0 = 1|0 = 0|0 = 0|0

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 2|0 = 0|1

0

51

1|1 = 0|0 = 1|0 = 1|0 = 1|0 = 0|0 = 0|1

0|0 = 0|0 = 0|0 = 0|2 = 0|2 = 2|0 = 1|0

0

52

1|0 = 1|0 = 0|0 = 0|0 = 0|1 = 0|1 = 0|1

0|0 = 0|0 = 0|0 = 0|2 = 1|0 = 0|2 = 0|2

0

53

0|0 = 0|0 = 1|0 = 1|0 = 2|0 = 0|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 1|0 = 0|2 = 1|1

0

54

1|0 = 0|0 = 1|0 = 0|1 = 0|0 = 1|1 = 0|0

0|0 = 0|0 = 0|0 = 0|2 = 1|0 = 0|2 = 2|0

0

55

0|0 = 2|0 = 1|0 = 0|0 = 2|0 = 1|1 = 0|0

0|0 = 0|0 = 0|0 = 0|2 = 1|0 = 1|1 = 0|2

0

56

0|1 = 0|1 = 0|0 = 1|1 = 1|0 = 2|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 1|0 = 1|1 = 1|1

0

57

0|0 = 1|0 = 0|1 = 0|0 = 0|0 = 1|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 1|0 = 1|1 = 2|0

0

58

0|1 = 0|1 = 1|0 = 0|0 = 0|0 = 1|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 1|0 = 2|0 = 0|2

0

59

0|0 = 0|0 = 0|1 = 1|0 = 0|2 = 1|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 1|0 = 2|0 = 1|1

0

60

0|1 = 1|0 = 0|0 = 1|0 = 0|0 = 2|0 = 1|1

0|0 = 0|0 = 0|0 = 0|2 = 1|0 = 2|0 = 2|0

0

61

0|0 = 0|0 = 1|0 = 1|0 = 0|0 = 0|1 = 0|1

0|0 = 0|0 = 0|0 = 0|2 = 1|1 = 0|1 = 0|2

0

62

0|0 = 0|0 = 0|0 = 0|1 = 0|1 = 0|0 = 1|0

0|0 = 0|0 = 0|0 = 0|2 = 1|1 = 0|1 = 1|1

0

63

0|1 = 0|0 = 0|2 = 0|2 = 0|0 = 0|0 = 1|1

0|0 = 0|0 = 0|0 = 0|2 = 1|1 = 0|1 = 2|0

0

Sheet1

Cell Formulas
Range	Formula
G4	=COUNTIF($D$4:$D$10000,F4)

Thank you all
Excel 2000
Regards,
Moti

Fluff · Oct 8, 2018

How about

Code:

Sub MyCountif()
   With Range("G4", Range("F" & Rows.Count).End(xlUp).Offset(, 1))
      .Value = Evaluate("if({1},countif($D$4:$D$10000," & .Offset(, -1).Address & "))")
   End With
End Sub

lrobbo314 · Oct 8, 2018

Not sure if this is faster than the 'Evaluate' approach, but here's is my version.

Code:

Sub test()
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")
Dim R As Range: Set R = Range("F4:F" & Range("F" & Rows.Count).End(xlUp).Row)
Dim AR1() As Variant: AR1 = Range("D4:D" & Range("D" & Rows.Count).End(xlUp).Row).Value
Dim AR2() As Variant: AR2 = R.Value


With Dict
    For i = 1 To UBound(AR2)
        .Add AR2(i, 1), 0
    Next i
    
    For j = 1 To UBound(AR1)
        If .exists(AR1(j, 1)) Then
            .Item(AR1(j, 1)) = .Item(AR1(j, 1)) + 1
        End If
    Next j
    
    R.Offset(, 1) = Application.Transpose(Array(.items))
End With


End Sub

motilulla · Oct 8, 2018

Fluff said:

How about

Code:

Sub MyCountif()
   With Range("G4", Range("F" & Rows.Count).End(xlUp).Offset(, 1))
      .Value = Evaluate("if({1},countif($D$4:$D$10000," & .Offset(, -1).Address & "))")
   End With
End Sub

Fluff, thank you it worked perfect and took time 18,56 sec to finish, it is really very faster than the formula I were using

Thank you for your help

Kind Regards,
Moti

motilulla · Oct 8, 2018

lrobbo314 said:
Not sure if this is faster than the 'Evaluate' approach, but here's is my version.

lrobbo314, thank you for the code, please could you check it stop at the line below. And I am sure it is my excel version 2000 not the code.

Code:

R.Offset(, 1) = Application.Transpose(Array(.items))

Kind Regards,
Moti

lrobbo314 · Oct 8, 2018

What error is it giving you? Excel 2000 is pretty old. I tested the code and it works on this end. I don't know what about Excel 2000 would make it error out. Which is a bummer too because on my test data it was about 8x faster.

Fluff · Oct 8, 2018

I'm not sure you can transpose will work with 62000 values in xl2000
Try this modified version instead

Code:

Sub test()
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")
Dim R As Range: Set R = Range("F4:G" & Range("F" & Rows.Count).End(xlUp).Row)
Dim AR1() As Variant: AR1 = Range("D4:D" & Range("D" & Rows.Count).End(xlUp).Row).Value
Dim AR2() As Variant: AR2 = R.Value


With Dict
    For i = 1 To UBound(AR2)
        .Add AR2(i, 1), i
        AR2(i, 2) = 0
    Next i
    
    For j = 1 To UBound(AR1)
        If .exists(AR1(j, 1)) Then
            AR2(.Item(AR1(j, 1)), 2) = AR2(.Item(AR1(j, 1)), 2) + 1
        End If
    Next j
    
    R.Offset(, 1).Resize(, 1) = Application.Index(AR2, 0, 2)
End With


End Sub

Fluff · Oct 8, 2018

Just tested the original code from lrobbo314 in Xl2003 & it works for me.

lrobbo314 · Oct 8, 2018

Oh yeah, you're right. I always forget about that limitation, especially since my test data didn't have that many rows.

Good call Fluff!

motilulla · Oct 8, 2018

lrobbo314 said:
What error is it giving you? Excel 2000 is pretty old. I tested the code and it works on this end. I don't know what about Excel 2000 would make it error out. Which is a bummer too because on my test data it was about 8x faster.

lrobbo314, it is giving an error 13

Need VBA, instead using formula

motilulla

Well-known Member

Excel Facts

Fluff

MrExcel MVP, Moderator

lrobbo314

Well-known Member

motilulla

Well-known Member

motilulla

Well-known Member

lrobbo314

Well-known Member

Fluff

MrExcel MVP, Moderator

Fluff

MrExcel MVP, Moderator

lrobbo314

Well-known Member

motilulla

Well-known Member

Similar threads

Forum statistics

Share this page

Need VBA, instead using formula

Well-known Member

Excel Facts

MrExcel MVP, Moderator

Well-known Member

Well-known Member

Well-known Member

Well-known Member

MrExcel MVP, Moderator

MrExcel MVP, Moderator

Well-known Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock