楼主
liuguansky |
Q;如何进行疾病的漏报分类统计？
A:用如下代码可以实现：
- Sub justtest()
- Dim dic, arr, i&, j&, k&, t&, m&, n&, x&, y&, arrt(), arrre()'定义名称
- Set dic = CreateObject("scripting.dictionary")'创建字典项目
- t = Cells(Rows.Count, "f").End(3).Row - 3'获取F列最后非空单元格行号，－3为去除表头
- arr = Cells(4, "f").Resize(t, 6).Value'把汇总数据源装入数组，用于内存调用
- For i = 1 To t'在数组中循环
- If dic.exists(arr(i, 1)) Then' 如果是存在的病名即之前已做字典添加的项目，则
- j = dic(arr(i, 1))'获取该病名所对应的ITEM值，即在生成的汇总数组中的行号，把它赋值给变量J
- arrt(2, j) = arrt(2, j) + 1'对人数进行累加1
- If arr(i, 6) <> "" Then arrt(3, j) = arrt(3, j) + 1'如果为漏报，刚累加1
- Else: k = k + 1: ReDim Preserve arrt(1 To 3, 1 To k): dic.Add arr(i, 1), k'如果病名第一次出现，刚
- '添加到字典项目，同时汇总记录数组也扩展一位，同时定义动态数组，用来返回汇总数组：注意K标识位的运用
- arrt(1, k) = arr(i, 1): arrt(2, k) = 1'同时对病名赋值，人数初始化1
- If arr(i, 3) <> "" Then arrt(3, k) = 1'如果为漏报，人数初始化1
- End If结束判断
- Next i'进入循环下一次
- Set dic = Nothing'清空字典内存
- j = Int(k / 2) + IIf(k Mod 2, 1, 0)'返回依实际汇总格式的行数
- ReDim arrre(1 To j, 1 To 6)'定义汇总格式数组
- For i = 1 To k Step 2'在汇总数组中循环，STEP2是因为汇总格式为两列返回。
- x = x + arrt(2, i) + arrt(2, i + 1)'累加总人数
- y = y + arrt(3, i) + arrt(3, i + 1)'累加总漏人数
- m = (i + 1) / 2'返回汇总数组对应的汇总格式数组对应的列
- For t = 0 To 3 Step 3'因为一条记录三列，所以STEP3.只有两列，所以只循环两次
- n = i + t / 3'返回汇总格式数组对应的汇总数组的列数[这里因为一行有两条记录，所以为t/3返回0，1]
- arrre(m, t + 1) = arrt(1, n): arrre(m, t + 2) = arrt(2, n)'对不需判断的直接赋值
- If arrt(3, n) <> "" Then
- arrre(m, t + 3) = arrt(3, n) & "（" & Format(arrt(3, n) / arrt(2, n), "0.00%") & "）"
- End If '对漏报人数进行判断，如果没有就对应第三列返回空，如果有，就进行百分比运算。
- Next t
- Next i
- With Sheet2'获取汇总格式表
- .Range("a4:f" & Rows.Count).ClearContents'清除数据，避免影响
- .Cells(4, 1).Resize(j, 6) = arrre'对区域赋值汇总格式数组
- With .Cells(j + 5, 4)'生成表尾的合计行。
- .Value = "合计"
- .Offset(0, 1).Value = x
- .Offset(0, 2).Value = y
- End With
- .Activate
- End With
- MsgBox "统计结束."'友好提示。
- End Sub
具体示例文件如下：
|
2楼
wjc2090742 |
 留个位置，这个题目是我学excel的理由的题目的第二步。等完成第一步了再来学习。 |
3楼
nothingwmm |
花花的代码写的很工整，条理很清晰，很值得学习呀，
 |
4楼
liuguansky |
 已作注解，请指点。 |
5楼
gwfzh |
谢谢老师的帮助！但如将sheet1表的f列的疾病进行调整的话，总是在 x = x + arrt(2, i) + arrt(2, i + 1)（下面红色字体）处出现“下标越界”的错误？另外总漏报数不对，统计的是42例，排序后得出的是24例，望老师能继续帮助！予以解惑，先谢谢了！祝圣诞快乐！
 下标越界.rar
Sub justtest()
Dim dic, arr, i&, j&, k&, t&, m&, n&, x&, y&, arrt(), arrre()
Set dic = CreateObject("scripting.dictionary")
t = Cells(Rows.Count, "f").End(3).Row - 3
arr = Cells(4, "f").Resize(t, 6).Value
For i = 1 To t
If dic.exists(arr(i, 1)) Then
j = dic(arr(i, 1))
arrt(2, j) = arrt(2, j) + 1
If arr(i, 6) <> "" Then arrt(3, j) = arrt(3, j) + 1
Else: k = k + 1: ReDim Preserve arrt(1 To 3, 1 To k): dic.Add arr(i, 1), k
arrt(1, k) = arr(i, 1): arrt(2, k) = 1
If arr(i, 3) <> "" Then arrt(3, k) = 1
End If
Next i
Set dic = Nothing
j = Int(k / 2) + IIf(k Mod 2, 1, 0)
ReDim arrre(1 To j, 1 To 6)
For i = 1 To k Step 2
x = x + arrt(2, i) + arrt(2, i + 1)
y = y + arrt(3, i) + arrt(3, i + 1)
m = (i + 1) / 2
For t = 0 To 3 Step 3
n = i + t / 3
arrre(m, t + 1) = arrt(1, n): arrre(m, t + 2) = arrt(2, n)
If arrt(3, n) <> "" Then
arrre(m, t + 3) = arrt(3, n) & "（" & Format(arrt(3, n) / arrt(2, n), "0.00%") & "）"
End If
Next t
Next i
With Sheet2
.Range("a4:f" & Rows.Count).ClearContents
.Cells(4, 1).Resize(j, 6) = arrre
With .Cells(j + 5, 4)
.Value = "合计"
.Offset(0, 1).Value = x
.Offset(0, 2).Value = y
End With
.Activate
End With
MsgBox "统计结束."
End Sub |