With Sheet2 With Sheets"分类统计" 直观
===================================
单元格 用 颜色来操作 的 方法 不推荐
重新写的, 按 手册号操作的
①【分类统计 】89 行 扇尾沙锥 的 手册号 应该 是错了
② 空白的 , 增加了几个, 算 修改了 数据源
======================================
' 供 参考
Sub 综合统计_多年()
Dim 列序_arr0, 鸟分类_arr0, 数据源_arr0, 结果_arr9(1 To 1000, 1 To 20), r0&, c0&
Dim i&, j&, k&, 鸟分类$, 列9&
Dim D_列序, D_鸟分类, D_发现
Dim t
t = Timer
Set D_列序 = CreateObject("scripting.dictionary")
Set D_鸟分类 = CreateObject("scripting.dictionary")
Set D_发现 = CreateObject("scripting.dictionary")
With ThisWorkbook
With .Sheets("综合统计")
列序_arr0 = .Range("B22:G22").Value
End With
For i& = 1 To UBound(列序_arr0, 2)
D_列序(列序_arr0(1, i&)) = i&
Next i&
With .Sheets("手册鸟名录")
鸟分类_arr0 = .Range("B3:F" & .Range("B3").End(xlDown).Row).Value
End With
For i& = 1 To UBound(鸟分类_arr0)
D_鸟分类(鸟分类_arr0(i&, 1)) = 鸟分类_arr0(i&, 5)
Next i&
With .Sheets("分类统计")
r0& = .Range("g65536").End(xlUp).Row
c0& = .Range("IV2").End(xlToLeft).Column - 1
数据源_arr0 = .Range("A1").Resize(r0&, c0&).Value
End With
For i& = 9 To c0& Step 3
k& = k& + 1
结果_arr9(k&, 1) = Left(数据源_arr0(2, i&), 4) '年份
' Stop
For j& = 4 To r0&
If 数据源_arr0(j&, i& + 1) <> 0 Then '有数据 (出现地点)
鸟分类$ = D_鸟分类(数据源_arr0(j&, 6))
列9& = D_列序(鸟分类$) + 1
If D_发现.Exists(数据源_arr0(j&, 6)) = False Then
'新拍
D_发现(数据源_arr0(j&, 6)) = 1 '
' If i& = 18 Then Debug.Print 数据源_arr0(j&, 6)
结果_arr9(k&, 8) = 结果_arr9(k&, 8) + 1 '新拍鸟
结果_arr9(1000, 列9&) = 结果_arr9(1000, 列9&) + 1 '新拍鸟 行累计
End If
结果_arr9(k&, 列9&) = 结果_arr9(k&, 列9&) + 1 '年度&分类 +1
结果_arr9(k&, 9) = 结果_arr9(k&, 9) + 1 '年度小计 +1
End If
Next j&
Next i&
k& = k& + 1
结果_arr9(k&, 1) = "累计新鸟种数"
For i& = 2 To 10
结果_arr9(k&, i&) = 结果_arr9(1000, i&)
Next i&
' .Sheets("综合统计").Range("A24").Resize(1000, 12).Clear
.Sheets("综合统计").Range("A24").Resize(k&, 11).Value = 结果_arr9
.Sheets("综合统计").Select
' Stop
End With
Debug.Print "用时 " & Timer - t & "秒"
End Sub