Excel VBA多条件不重计数

领导的要求

    先介绍下题目吧，领导的要求是从左侧的明细中统计出各个城市的公司数量和老板数量，去掉重复的那种。

VBA字典计算不重复数

    在Excel中，计数的方法其实还挺多的，比如最容易上手的COUNT系列函数，对于直接数数是非常好用的，无论是空的、非空的，还是要条件的，都没有问题。可如果遇到条件去重就困难了，这个时候可以用sumproduct和countif函数组合解决。

    可今天的数据有点多了，数组公式直接超出了Excel允许的最大变量范围了。所以没办法，小编只好祭出了VBA编程大法，好在一通现学现用之后，成功搞定。

    整体思路就是：

1）先提取出不重复的地区。代码逻辑是将源数据拷贝到结果表中，然后选择前两列数据，删除重复数据项。

2）For循环遍历源数据数组，将符合条件的公司名称存储到临时数组中，为了去重，我们将临时数组中的公司名称存储到字典中。

3）逐行遍历结果工作表，将字典的条目数赋值到“公司数量”对应列。

4）地区对应的老板数量。为了更好地学习，在统计老板数量时，我们换一个思路，将源数据拷贝至临时表中，以前4列为条件，删除重复数据记录。然后遍历临时数组，将符合条件的老板数量赋值到“老板数量”对应列。

    完整的代码在这里，欢迎拿走，当然，如果能点个赞就更不胜感激了。

Sub 宏2()
Sheets("Sheet1").Select
    '历史数据清理,ClearContents,Clear
    Sheets("Sheet3").UsedRange.Clear
    '将工作表“Sheet1”分中国、所属区域单元格区域内容拷贝至工作表“Sheet3”，并删除重复数据记录
    Range("A1:b1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet3").Select
   Sheet3.Range("A1").PasteSpecial
    'Header:=xlYes 数据包含标题
    Sheet3.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    
    '工作表“Sheet1”单元格内容存储到数组source_arr中,统计所属区域医院数量
    source_arr = Sheets("Sheet1").[a1].CurrentRegion
    'sheet_i 逐行遍历结果工作表Sheet3使用,source_arr_i遍历源数组source_arr使用
    Dim sheet_i, source_arr_i As Integer
    'sheet_i = 2 '第一行为标题，从第二行开始遍历
    source_arr_i = 1
Cells(1, 3).Value = "公司数量"
Cells(1, 4).Value = "老板数量"
  '创建和使用Dictionary对象
  Set d = CreateObject("scripting.dictionary")
    Dim arr_hospital_all() As String '声明一维动态数组，存储所属区域医院条目
    Dim arr_hospital_all_i As Integer
'工作表Sheet3遍历的最大值为A列的非空单元格数量， 第一行为标题，从第二行开始遍历
For sheet_i = 2 To WorksheetFunction.CountA([A:A])
    '清理临时字典和数组数据，将arr_hospital_all_i 变量重置为1
    d.RemoveAll '清理字典数据
    Erase arr_hospital_all
    arr_hospital_all_i = 1
    '确定动态数组的上界
    ReDim arr_hospital_all(UBound(source_arr))
        '遍历数组，是否匹配，匹配写入临时数组
    For source_arr_i = 1 To UBound(source_arr)
        If Cells(sheet_i, 1).Value = source_arr(source_arr_i, 1) And Cells(sheet_i, 2).Value = source_arr(source_arr_i, 2) Then
            arr_hospital_all(arr_hospital_all_i) = source_arr(source_arr_i, 3)
            arr_hospital_all_i = arr_hospital_all_i + 1
        End If
    Next

    '医院数据记录去重，将内容存储在字典中；数据中包含空记录，增加为空判断，
    For arr_hospital_all_i = 1 To UBound(arr_hospital_all)
    If Not (d.exists(arr_hospital_all(arr_hospital_all_i)) Or arr_hospital_all(arr_hospital_all_i) = "") Then
        d.Add arr_hospital_all(arr_hospital_all_i), ""
    End If
    Next
    Cells(sheet_i, 3).Value = d.Count   '字典条目数为所属区域医院数量，赋值到结果工作表Sheet3的第3列

Next
 
'复制工作表sheet1，将副本放在工作表sheet3之后
Sheets("Sheet1").Copy after:=Sheet3
Sheets("Sheet1 (2)").UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo

'统计医生数量
doctor_source_arr = Sheets("Sheet1 (2)").[a1].CurrentRegion
Dim doctor_source_arr_i, doc_num As Integer

    Sheets("Sheet3").Select
For sheet_i = 2 To WorksheetFunction.CountA([A:A])

    doc_num = 0
    For doctor_source_arr_i = 1 To UBound(doctor_source_arr)
    If Cells(sheet_i, 1).Value = doctor_source_arr(doctor_source_arr_i, 1) And Cells(sheet_i, 2).Value = doctor_source_arr(doctor_source_arr_i, 2) And doctor_source_arr(doctor_source_arr_i, 3) <> "" Then
    doc_num = doc_num + 1
    End If
    Next
    Cells(sheet_i, 4).Value = doc_num   '字典条目数为所属区域医院数量，赋值到结果工作表Sheet3的第3列
Next
 
Sheets("Sheet1 (2)").Delete
End Sub