【问题】我们在统计时，可以用函数统计，但每一次数据变动后要把公式再输入或调整一次
***我想能不能“偷懒“
***经过学习与测试，成功了，在此记录一下学习成果
【使用方法】
蓝色为你填写单元格
条件：任意个
项目：任意个
“任意”当然要是数据区域的标题哦
【代码】
代码语言：javascript复制 '使用方法，□处等待你的输入
'1.工作表名为“通用统计”
'第一行：工作表,□，数据区域，□
'第二行：条件，□，□，□。。。
'第三行：项目，□，□，□。。。
Sub 通用统计()
Dim karr, darr, res
With Worksheets("通用统计")
.Range("A4").Resize(1000, 200) = ""
A2Col = .Range("XFD2").End(xlToLeft).Column
A3Col = .Range("XFD3").End(xlToLeft).Column
arr = .Range("A2").Resize(1, A2Col).Value
brr = .Range("A3").Resize(1, A3Col).Value
.Range("A4").Resize(1, A2Col) = .Range("A2").Resize(1, A2Col).Value
.Range("A4").Offset(0, A2Col).Resize(1, A3Col) = .Range("A3").Resize(1, A3Col).Value
.Range("A4") = "序号"
.Range("A4").Offset(0, A2Col) = "人数"
shtName = .Range("B1").Value
dataRng = .Range("D1").Value
If Not SheetExists(shtName) Then MsgBox "工作表设置有误": Exit Sub
End With
With Worksheets(shtName)
crr = .Range(dataRng)
title_arr = Application.Index(crr, 1, 0)
ReDim karr(UBound(arr, 2) - 2)
ReDim darr(UBound(brr, 2) - 2)
m = 0
For j = 0 To UBound(karr)
karr(m) = Application.WorksheetFunction.Match(arr(1, j 2), title_arr, 0)
m = m 1
Next
m = 0
For j = 0 To UBound(darr)
darr(m) = Application.WorksheetFunction.Match(brr(1, j 2), title_arr, 0)
m = m 1
Next
End With
res = conSumArr(crr, karr, darr)
With Worksheets("通用统计")
.Range("B5").Resize(UBound(res, 1), UBound(res, 2)) = res
End With
End Sub
'任意多条件、任意多项目统计个数、汇总和，返回数组，使用方法：res=conSumArr(data_arr, conArray, itemArray)
'输出.Range("B5").Resize(UBound(res, 1), UBound(res, 2)) = res
'参数1：data_arr-含有标题行1行的数组
'参数2：conArray-一维数组Array(多条件)
'参数3：itemArray-一维数组Array(多个要统计项目)
Function conSumArr(data_arr, conArray, itemArray)
Dim t_d As Object, key_arr, mydata_arr, i%, j%, m%, dilimi As String, aCount%
delimi = "|"
Set t_d = CreateObject("scripting.dictionary")
ReDim key_arr(1 To UBound(data_arr, 1), 1 To UBound(conArray) 1)
For i = 2 To UBound(data_arr, 1)
j = 1
For Each con In conArray
key_arr(i, j) = data_arr(i, con)
j = j 1
Next
s = Join(Application.Index(key_arr, i, 0), delimi)
If Not t_d.exists(s) Then
m = m 1
t_d(s) = m
End If
Next i
aCount = t_d.Count
ReDim mydata_arr(1 To aCount, 1 To UBound(itemArray) 2)
For i = 2 To UBound(data_arr, 1)
s = Join(Application.Index(key_arr, i, 0), delimi)
n = t_d(s)
mydata_arr(n, 1) = mydata_arr(n, 1) 1
j = 2
For Each itemA In itemArray
mydata_arr(n, j) = mydata_arr(n, j) data_arr(i, itemA)
j = j 1
Next
Next i
ReDim result(1 To aCount, 1 To UBound(key_arr, 2) UBound(mydata_arr, 2))
' For m = 1 To UBound(result, 1)
For j = 1 To UBound(result, 2)
If j <= UBound(key_arr, 2) Then
result(m, j) = Split(t_d.keys()(m - 1), delimi)(j - 1)
Else
result(m, j) = mydata_arr(m, j - UBound(key_arr, 2))
End If
Next j
Next m
conSumArr = result
End Function
'检测工作表是否存在
Function SheetExists(sname) As Boolean
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then
SheetExists = True
Else
SheetExists = False
End If
End Function
【效果1】
条件：1个
项目：3个
效果2：
条件：2个
项目：4个
效果3：
条件：3个
项目：6个
