counting comma delimited in a range

[airforceone]

In a single structured value I managed to count using below code

    Dim LastRow as long, eWan as integer 
    LastRow = 136
    eWan = 3
    Lr0W = 10
    iLOOP = 2
    Do While eWan <= Lr0W 
        Cells(eWan, iLOOP).Formula = "=SUM(COUNTIFS('DREC'!$A$2:$A" & LastRow & ",$A3,'DREC'!$B$2:$B" & LastRow & ",$B$1,'DREC'!$C$2:$C" & LastRow & ",""Hatched""))"       
        eWan = eWan + 1
    Loop

but since I have a loving and very thoughtful supervisor (pun intended) he manage to change it in a comma delimited range value thus the problem arise. anyway I have below a running code for such problem but needed to merge with the above code since I do need to check first the Specie and country before counting the Gender/Sex of the fish/specie

    Dim iSum As Long
    iSum = Len(Sheets("DREC").Cells(2, 4)) - Len(Replace(Sheets("DREC").Cells(2, 4, "F", ""))

the logic would be if Sheet DREC Specie = Sheet UPDATED Specie AND Sheet DREC Country = Sheet UPDATED Country then count Gender/Sex under such condition, just like the first code but now counting the Gender/Sex in a comma delimited value...

SAMPLE DATA

X ONLINE DUMMY RECORD.xlsx
	A	B	C	D
1	SPECIE	COUNTRY	STATUS	GENDER
2	American flamingo	Afghanistan	Hatched	M,M,M,F
3	Alcids	Afghanistan	Hatched	F,F,M,F
4	Amazon kingfisher	Afghanistan	Hatched	F
5	Albatrosses	Afghanistan	Sold	M
6	Albatrosses	Afghanistan	Sold	F,F
7	Accipiter hawks	Afghanistan	Sold	M,F
8	Accipiter hawks	Afghanistan	Sold	F
9	American dipper	Albania	Hatched	M,M,M
10	Accipiter hawks	Albania	Hatched	F,F,F,F
11	Albatrosses	Albania	Sold	M,F
12	American flamingo	Algeria	Hatched	M
13	Albatrosses	Algeria	Sold	M
14	Albatrosses	Algeria	Sold	F
15	Accipiter hawks	Algeria	Sold	F
16	American dipper	Andorra	Hatched	M
17	Alcids	Andorra	Hatched	M
18	Albatrosses	Andorra	Sold	M
19	Albatrosses	Andorra	Hatched	F
20	Accipiter hawks	Andorra	Sold	F,F
21	Albatrosses	Angola	Sold	F,M
22	Accipiter hawks	Angola	Sold	M,M,M
23	Albatrosses	Antigua and Barbuda	Sold	M
24	Albatrosses	Antigua and Barbuda	Sold	M
25	Albatrosses	Antigua and Barbuda	Sold	M
26	Albatrosses	Antigua and Barbuda	Sold	F
27	Albatrosses	Antigua and Barbuda	Sold	F,F
28	Albatrosses	Antigua and Barbuda	Sold	F,M
29	Accipiter hawks	Antigua and Barbuda	Sold	M,M,M
30	Accipiter hawks	Antigua and Barbuda	Sold	M,F
31	Accipiter hawks	Antigua and Barbuda	Sold	M
32	Accipiter hawks	Antigua and Barbuda	Sold	M
33	Accipiter hawks	Antigua and Barbuda	Sold	M,F
34	Albatrosses	Argentina	Sold	M
35	Albatrosses	Argentina	Sold	M
36	Accipiter hawks	Argentina	Sold	M
37	Accipiter hawks	Argentina	Sold	M
38	American dipper	Armenia	Hatched	F
39	American kestrel	Armenia	Hatched	F,F
40	American white pelican	Armenia	Hatched	F,M
41	American white pelican	Armenia	Hatched	M,M,M
42	American white pelican	Armenia	Hatched	F,M
43	Albatrosses	Armenia	Sold	M,M,M
44	Albatrosses	Armenia	Sold	M,F
45	Albatrosses	Armenia	Sold	M
46	Albatrosses	Armenia	Sold	M
47	Albatrosses	Armenia	Hatched	M,F
48	Albatrosses	Armenia	Sold	M
49	Albatrosses	Armenia	Sold	M
50	Alcids	Armenia	Hatched	M
51	Accipiter hawks	Armenia	Sold	M
52	Accipiter hawks	Armenia	Sold	F
53	Accipiter hawks	Armenia	Sold	F,F
54	American dipper	Australia	Hatched	F,M
55	American white pelican	Australia	Hatched	M,M,M
56	Accipiter hawks	Australia	Sold	M,F
57	Accipiter hawks	Australia	Hatched	M
58	American dipper	Austria	Hatched	M
59	American dipper	Austria	Hatched	M,F
60	American kestrel	Austria	Hatched	M
61	American white pelican	Austria	Hatched	M
62	American white pelican	Austria	Hatched	M
63	Albatrosses	Austria	Sold	M
64	Albatrosses	Austria	Sold	F
65	Albatrosses	Austria	Sold	F,F
66	Albatrosses	Austria	Sold	F,M
67	Albatrosses	Austria	Sold	M,M,M
68	Albatrosses	Austria	Sold	M,F
69	Albatrosses	Austria	Sold	M
70	Albatrosses	Austria	Sold	M
71	Accipiter hawks	Austria	Sold	M,F
72	Accipiter hawks	Austria	Sold	M
73	Accipiter hawks	Austria	Sold	M
74	Accipiter hawks	Austria	Sold	M
75	American kestrel	Azerbaijan	Hatched	M
76	Albatrosses	Azerbaijan	Sold	F,M
77	American dipper	Bahamas	Hatched	M,M,M
78	American white pelican	Bahrain	Hatched	M,F
79	American dipper	Bangladesh	Hatched	M
80	Alcids	Bangladesh	Hatched	M
81	Accipiter hawks	Bangladesh	Hatched	M,F
82	American dipper	Barbados	Hatched	M
83	American kestrel	Barbados	Sold	M
84	American kestrel	Barbados	Hatched	M
85	American white pelican	Barbados	Hatched	M
86	American white pelican	Barbados	Hatched	F,M
87	Alcids	Barbados	Hatched	M,M,M
88	Accipiter hawks	Barbados	Hatched	M,F
89	Albatrosses	Barbados	Sold	M
90	Albatrosses	Barbados	Sold	M
91	Albatrosses	Barbados	Sold	M,F
92	Accipiter hawks	Barbados	Sold	M
93	Accipiter hawks	Barbados	Sold	M
94	American dipper	Belarus	Hatched	M
95	American white pelican	Belarus	Hatched	M
96	American white pelican	Belarus	Hatched	F,M
97	American white pelican	Belarus	Hatched	M,M,M
98	American white pelican	Belarus	Hatched	M,F
99	American white pelican	Belarus	Hatched	M
100	Alcids	Belarus	Hatched	M
101	Accipiter hawks	Belarus	Hatched	M,F
102	Albatrosses	Belarus	Sold	M
103	Albatrosses	Belarus	Sold	M
104	Albatrosses	Belarus	Sold	M
105	Accipiter hawks	Belarus	Sold	M
106	Accipiter hawks	Belarus	Sold	F,M
107	Albatrosses	Belgium	Sold	M,M,M
108	Albatrosses	Belgium	Sold	M,F
109	Accipiter hawks	Belgium	Sold	M
110	Accipiter hawks	Belgium	Sold	M
111	Alcids	Belize	Sold	M,F
112	Albatrosses	Belize	Sold	M
113	Accipiter hawks	Belize	Sold	M
114	American white pelican	Benin	Hatched	M
115	American white pelican	Benin	Hatched	M
116	Alcids	Benin	Hatched	F,M
117	Amazon kingfisher	Benin	Sold	M,M,M
118	Albatrosses	Benin	Sold	M,F
119	Albatrosses	Benin	Sold	M
120	Albatrosses	Benin	Sold	M
121	Albatrosses	Benin	Sold	M,F
122	Accipiter hawks	Benin	Sold	M
123	Accipiter hawks	Benin	Sold	M
124	Accipiter hawks	Benin	Sold	M
125	Amazon kingfisher	Bhutan	Sold	M
126	Albatrosses	Bolivia	Sold	F,M
127	Albatrosses	Bolivia	Sold	M,M,M
128	Albatrosses	Bolivia	Sold	M,F
129	Accipiter hawks	Bolivia	Sold	M
130	Accipiter hawks	Bolivia	Sold	M
131	Accipiter hawks	Bolivia	Sold	M,F
132	Albatrosses	Bosnia and Herzegovina	Sold	M
133	Albatrosses	Bosnia and Herzegovina	Sold	M
134	American kestrel	Botswana	Hatched	M
135	Albatrosses	Botswana	Sold	M
136	Alcids	Botswana	Sold	N
DREC

X ONLINE DUMMY RECORD.xlsx
	A	B	C	D	E	F	G	H	I	J
1	SPECIE	Afghanistan			Antigua and Barbuda			Barbados
2		FEMALE	MALE	Total	FEMALE	MALE	Total	FEMALE	MALE	Total
3	American flamingo
4	Alcids
5	Amazon kingfisher
6	Albatrosses
7	Accipiter hawks
8	American dipper
9	American kestrel
10	American white pelican
11	Grand Total
UPDATED

 

[bebo021999]

Try:

Option Explicit
Sub test()
Dim dicS As Object, dicC As Object, dicA As Object
Dim lr&, i&, j&, n&, F&, M&, freq&, key, s, id As String, gen As String, cell As Range, rng, arr()
Set dicS = CreateObject("Scripting.dictionary")
Set dicC = CreateObject("Scripting.dictionary")
Set dicA = CreateObject("Scripting.dictionary")
Worksheets("DREC").Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:D" & lr).Value
    For i = 1 To lr - 1
        M = 0: F = 0: gen = ""
        s = Split(rng(i, 4), ",")
        id = rng(i, 1) & "|" & rng(i, 2)
        If Not dicA.exists(id) And rng(i, 3) = "Hatched" Then
            For n = 1 To Len(rng(i, 4))
                Select Case Mid(rng(i, 4), n, 1)
                    Case "F"
                        F = F + 1
                    Case "M"
                        M = M + 1
                End Select
            Next
            gen = M & "," & F & "," & M + F
            dicA.Add id, gen
        End If
        If Not dicS.exists(rng(i, 1)) And rng(i, 3) = "Hatched" Then dicS.Add rng(i, 1), ""
        If Not dicC.exists(rng(i, 2)) And rng(i, 3) = "Hatched" Then dicC.Add rng(i, 2), ""
    Next
ReDim arr(1 To dicS.Count + 1, 1 To dicC.Count * 3)
Worksheets("UPDATED").Activate
Range("A3").Resize(dicS.Count, 1) = WorksheetFunction.Transpose(dicS.keys)
    For i = 1 To dicS.Count
        For j = 1 To dicC.Count * 3
            freq = Evaluate("Mod(" & j - 1 & ",3" & ")")
            For Each key In dicA.keys
                If key Like dicS.keys()(i - 1) & "|" & dicC.keys()(Int((j - 1) / 3)) Then
                    arr(i, j) = Split(dicA(key), ",")(freq)
                End If
            Next
            If freq = 1 Then
                Cells(1, j).Value = dicC.keys()(Int((j - 1) / 3))
                Cells(2, j).Resize(1, 3).Value = Array("FEMALE", "MALE", "Total")
            End If
        Next
    Next
Range("B3").Resize(i, j - 1) = arr
End Sub

 

[airforceone]

Try:

Option Explicit
Sub test()
Dim dicS As Object, dicC As Object, dicA As Object
Dim lr&, i&, j&, n&, F&, M&, freq&, key, s, id As String, gen As String, cell As Range, rng, arr()
Set dicS = CreateObject("Scripting.dictionary")
Set dicC = CreateObject("Scripting.dictionary")
Set dicA = CreateObject("Scripting.dictionary")
Worksheets("DREC").Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:D" & lr).Value
    For i = 1 To lr - 1
        M = 0: F = 0: gen = ""
        s = Split(rng(i, 4), ",")
        id = rng(i, 1) & "|" & rng(i, 2)
        If Not dicA.exists(id) And rng(i, 3) = "Hatched" Then
            For n = 1 To Len(rng(i, 4))
                Select Case Mid(rng(i, 4), n, 1)
                    Case "F"
                        F = F + 1
                    Case "M"
                        M = M + 1
                End Select
            Next
            gen = M & "," & F & "," & M + F
            dicA.Add id, gen
        End If
        If Not dicS.exists(rng(i, 1)) And rng(i, 3) = "Hatched" Then dicS.Add rng(i, 1), ""
        If Not dicC.exists(rng(i, 2)) And rng(i, 3) = "Hatched" Then dicC.Add rng(i, 2), ""
    Next
ReDim arr(1 To dicS.Count + 1, 1 To dicC.Count * 3)
Worksheets("UPDATED").Activate
Range("A3").Resize(dicS.Count, 1) = WorksheetFunction.Transpose(dicS.keys)
    For i = 1 To dicS.Count
        For j = 1 To dicC.Count * 3
            freq = Evaluate("Mod(" & j - 1 & ",3" & ")")
            For Each key In dicA.keys
                If key Like dicS.keys()(i - 1) & "|" & dicC.keys()(Int((j - 1) / 3)) Then
                    arr(i, j) = Split(dicA(key), ",")(freq)
                End If
            Next
            If freq = 1 Then
                Cells(1, j).Value = dicC.keys()(Int((j - 1) / 3))
                Cells(2, j).Resize(1, 3).Value = Array("FEMALE", "MALE", "Total")
            End If
        Next
    Next
Range("B3").Resize(i, j - 1) = arr
End Sub

thanks for the time mate,

running the code seems to work except it's not accurate
ie.
Afghanistan should be 6 Male and 9 Female for a total of 15
Albania should 4 Male and 5 Female total 9

 

[bebo021999]

According to your initial formula:

=SUM(COUNTIFS('DREC'!$A$2:$A" & LastRow & ",$A3,'DREC'!$B$2:$B" & LastRow & ",$B$1,'DREC'!$C$2:$C" & LastRow & ",""Hatched"")

With "Hatched" is 1 of condition to count.
Without "Hatched", Afghanistan Male is 6
With "Hatched" it is 4 (As my code)
What 'd your condition, with or without "Hatched"?

 

[airforceone]

the logic would be if Sheet DREC Specie = Sheet UPDATED Specie AND Sheet DREC Country = Sheet UPDATED Country then count Gender/Sex under such condition, just like the first code but now counting the Gender/Sex in a comma delimited value...

sorry mate its my fault for not making it clear
I'm not counting the hatched anymore but the Gender/Sex as what stated above...

 

[bebo021999]

There were 3 of

And rng(i, 3) = "Hatched"

in my code. Just delete and try again.

 

[airforceone]

There were 3 of

And rng(i, 3) = "Hatched"

in my code. Just delete and try again.

did already but its short of 3 (for Afghanistan) Female is correct 6 but the male should be 9

 

[airforceone]

up...

 

[Alex Blakenburg]

I personally think you would be better served by a pivot table. It would give you options in how you analyse the data eg.

20220524 VBA Sum Comma Delimited airforceone v03.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	SPECIE	COUNTRY	STATUS	GENDER	Female	Male
2	American flamingo	Afghanistan	Hatched	M,M,M,F	1	3
3	Alcids	Afghanistan	Hatched	F,F,M,F	3	1				COUNTRY	Values
4	Amazon kingfisher	Afghanistan	Hatched	F	1	0				Afghanistan			Albania
5	Albatrosses	Afghanistan	Sold	M	0	1			SPECIE	Female	Male	Gender Total	Female	Male	Gender Total
6	Albatrosses	Afghanistan	Sold	F,F	2	0			Accipiter hawks	2	1	3	4	0	4
7	Accipiter hawks	Afghanistan	Sold	M,F	1	1			Albatrosses	2	1	3	1	1	2
8	Accipiter hawks	Afghanistan	Sold	F	1	0			Alcids	3	1	4			0
9	American dipper	Albania	Hatched	M,M,M	0	3			Amazon kingfisher	1	0	1			0
10	Accipiter hawks	Albania	Hatched	F,F,F,F	4	0			American dipper			0	0	3	3
11	Albatrosses	Albania	Sold	M,F	1	1			American flamingo	1	3	4			0
12	American flamingo	Algeria	Hatched	M	0	1			American kestrel			0			0
13	Albatrosses	Algeria	Sold	M	0	1			American white pelican			0			0
14	Albatrosses	Algeria	Sold	F	1	0			Grand Total	9	6	15	5	4	9
15	Accipiter hawks	Algeria	Sold	F	1	0
16	American dipper	Andorra	Hatched	M	0	1
17	Alcids	Andorra	Hatched	M	0	1
18	Albatrosses	Andorra	Sold	M	0	1
DREC

Cell Formulas
Range	Formula
E2:F18	E2	=LEN($D2)-LEN(SUBSTITUTE($D2,LEFT(E$1,1),""))

 

[Alex Blakenburg]

If you really want to use VBA, I have made some modifications to @bebo021999's code, see if that works for you.

Sub test_v02()
    Dim dicS As Object, dicC As Object, dicA As Object
    Dim lr&, i&, j&, n&, F&, M&, freq&, key, s, id As String, gen As String, cell As Range, rng, arr()
    Dim sDic As Variant
    Set dicS = CreateObject("Scripting.dictionary")
    Set dicC = CreateObject("Scripting.dictionary")
    Set dicA = CreateObject("Scripting.dictionary")
    Worksheets("DREC").Activate
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    rng = Range("A2:D" & lr).Value
    For i = 1 To lr - 1
        s = Split(rng(i, 4), ",")
        id = rng(i, 1) & "|" & rng(i, 2)
        If dicA.exists(id) Then
            sDic = Split(dicA(id), ",")
            F = sDic(0): M = sDic(1): gen = sDic(2)
        Else
            F = 0: M = 0: gen = ""
        End If
        For n = 1 To Len(rng(i, 4))
            Select Case Mid(rng(i, 4), n, 1)
                Case "F"
                    F = F + 1
                Case "M"
                    M = M + 1
            End Select
        Next
            gen = F & "," & M & "," & M + F         ' XXX Swapped M & F
            dicA(id) = gen
        If Not dicS.exists(rng(i, 1)) Then dicS.Add rng(i, 1), ""
        If Not dicC.exists(rng(i, 2)) Then dicC.Add rng(i, 2), ""
    Next
    ReDim arr(1 To dicS.Count + 1, 1 To dicC.Count * 3)
    Worksheets("UPDATED").Activate
    Range("A3").Resize(dicS.Count, 1) = WorksheetFunction.Transpose(dicS.keys)
    For i = 1 To dicS.Count
        For j = 1 To dicC.Count * 3
            freq = Evaluate("Mod(" & j - 1 & ",3" & ")")
            For Each key In dicA.keys
                If key Like dicS.keys()(i - 1) & "|" & dicC.keys()(Int((j - 1) / 3)) Then
                    arr(i, j) = Split(dicA(key), ",")(freq)
                End If
            Next
            If freq = 1 Then
                Cells(1, j).Value = dicC.keys()(Int((j - 1) / 3))
                Cells(2, j).Resize(1, 3).Value = Array("FEMALE", "MALE", "Total")
            End If
        Next
    Next
    Range("B3").Resize(i, j - 1) = arr
End Sub