在 Excel VBA 中组合两列获取唯一计数

Question

I have an excel with columns

ID|Gender|Age|Center
1    M     20  Center1
1    M     24  Center1
2    M     25  Center2
3    F     30  Center2 
4    F     25  Center1

Total Males -   2   Total Males in Center1 - 1 
Total Females - 2   Total Females in Center2 - 1 

I want to count the unique combination of Id and Gender. Also, the same info required as center-wise.

Below is my code I am using but I am getting the 0 value in the required cell.

 Sub CountPopulation() 
 Dim rCell As Range  
 Dim rRng As Range    
 Dim countM As Integer  
 Dim countF As Integer  
 Dim name As String
Set rRng = Sheet1.Range("D2:D100") 

      For Each rCell In rRng.Cells
        If rCell.Value > name Then
            If rCell.Offset(0, 2).Value = "MALE" Then
                countM = countM + 1
            End If
            If rCell.Offset(0, 2).Value = "FEMALE" Then
                countF = countF + 1
            End If
        End If
        name = rCell.Value

      Next rCell


      Sheet2.Range("D4").Value = countM   Sheet2.Range("D5").Value = countF


    End Sub

Thanks

Answer 1

If you already have the new dynamic arrays, this is a pretty easy task. The formula to count unique combinations of ID and Gender would be:

=COUNTA(UNIQUE(A2:A6&B2:B6))

This formula first forms a unique list of (concatenated) IDs and genders, which looks such for you:

Then the COUNTA function will count the number of rows.

To apply this in VBA, you might use Evaluate() , something like this:

lUniqueCombinationsOfIDandGender = Evaluate("=COUNTA(UNIQUE(A2:A6&B2:B6))")

If you want to have the unique combinations of centers and ID, you can change the formula to:

=COUNTA(UNIQUE(A2:A6&D2:D6))

I assume that you do not have any blank rows in your data (otherwise, you will count one combination more than you actually have).

I hope that helps you.

Answer 2

If you really want to do it with VBA, this code helps you:

Option Explicit

Sub test()
Dim a As Integer, b As Integer, c As Integer
Dim D() As String, e As Integer, f As Integer

Range("A2").Select
a = Selection.End(xlDown).Row

ReDim D(2 To a)

For b = 2 To a
    D(b) = Cells(b, 1).Value & Cells(b, 2).Value
Next b

e = a - 1

For b = 2 To a
    f = D(b)
    For c = (b + 1) To a
        If f = D(c) Then
        e = e - 1
        Exit For
        End If
    Next c
Next b
MsgBox "Unique combinations: " & e

End Sub

The steps are as follows: 1. Count the last row used 2. Redimension the D array accordingly 3. For each row fill each D() with a string of the entrys of both columns 4. Set e = a - 1 (first assuming, all combinations are unique) 5. For all Rows: Compare its content with those of the following rows, until a match happens. Then move on with the next row.

Hope, this is helpfull to you.

Answer 3

I think this will solve what (I understood) you need:

  Dim rngVal As Variant, sh As Worksheet, El As Variant, boolM As Boolean, boolF As Boolean, i As Long
  Dim colM1 As New Collection, colM2 As New Collection, colF1 As New Collection, colF2 As New Collection

    Set sh = ActiveSheet 'not recommended but just for testing sake it is OK
    rngVal = sh.Range("A2:D" & sh.Range("A1").SpecialCells(xlCellTypeLastCell).Row).value

    For i = 1 To UBound(rngVal)
        boolM = False: boolF = False
        If rngVal(i, 4) = "Center1" Then
            If rngVal(i, 2) = "M" Then
                For Each El In colM1
                    If El = rngVal(i, 1) & rngVal(i, 1) Then boolM = True: Exit For
                Next
                If Not boolM Then colM1.Add rngVal(i, 1) & rngVal(i, 1): boolM = False
            ElseIf rngVal(i, 2) = "F" Then
                For Each El In colF1
                    If El = rngVal(i, 1) & rngVal(i, 1) Then boolF = True: Exit For
                Next
                If Not boolF Then colF1.Add rngVal(i, 1) & rngVal(i, 1): boolF = False
            End If
        ElseIf rngVal(i, 4) = "Center2" Then
            If rngVal(i, 2) = "M" Then
                For Each El In colM2
                    If El = rngVal(i, 1) & rngVal(i, 1) Then boolM = True: Exit For
                Next
                If Not boolM Then colM2.Add rngVal(i, 1) & rngVal(i, 1): boolM = False
            ElseIf rngVal(i, 2) = "F" Then
                For Each El In colF2
                    If El = rngVal(i, 1) & rngVal(i, 1) Then boolF = True: Exit For
                Next
                If Not boolF Then colF2.Add rngVal(i, 1) & rngVal(i, 1): boolF = False
            End If
        End If
    Next i
    Debug.Print "Total males : " & colM1.Count + colM2.Count
    Debug.Print "Total females: " & colF1.Count + colF2.Count
    Debug.Print "Males in Center1: " & colM1.Count, "Males in Center 2: " & colM2.Count
    Debug.Print "Females in Center1: " & colF1.Count, "Females in Center2: " & colF2.Count

The code puts the working range in a (variant) array and start processing. Each "M" and "F" of Center1 is added in appropriate collections (colM1, colF1) if they do not already exists there and does the same with Center2 members. Finally, the results are returned from the above mentioned collections using their `Count' property.