如何利用vba代码对特定排序规则条件区间内的图书内容进行统计?

awxgaige · 发表于 2012-4-13 08:52

Q: 如何利用vba代码对特定排序规则条件区间内的图书内容进行统计?
A: 规则说明如下:

在对馆藏的分类号字段进行了这种特殊“优先”次序规则的排序后，便是进行各个图书分类的种、册和总价。因为图书分类的特殊性，一般要求统计出分类号以什么什么开头的图书有多少种、多少册、总价值多少（比如统计以“E2”打头的有多少种、多少册、总价值多少），或者统计从什么什么开头到什么什么开头的图书又有多少种、多少册、总价值多少（比如统计从以“E”打头的第一本图书开始到以“E5”打头的最后一本图书止，这中间共有多少种、多少册、总价值多少的图书）。

一、分类号的比较是逐字符的；
二、分类号字符的优先顺序是：
a NULL / - ( ) “ ” = < > : + 0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z .
三、[]中的内容需包含在内，{}中内容为不包含在内

示例说明如下:

说明下为什么"[F12]~{F89}"这个区间还包括F2,F3,...,F7
对于前面两字符都是“F1”的 F12、F13、……、F18、F19 而言，显然有 F12《F13《……《F18《F19。
同理对于首字符都为“F”的 F1、F2、……、F7、F8 而言，又有 F1《F2《……《F7《F8。
而对于统计分类号 F1 而言，它是包括了 ……、F12、F13、……、F18、F19等等的，所以，又有
F12《F13《……《F18《F19《……《F2《F3《……《F7《F8。

而根据上面的分类号字符的优先顺序，“a”排在NULL前，NULL排在“/”前，“/”排在“-”前，……，“+”排在“0”前，“0”排在“1”前，……，因此对于前面两字符都是“F8”的 F8a、F8、F8/、F8-、……、F8+、F80、F81、…… 而言，又有 F8a《F8《F8/《F8-《……《F8+《F80《F81《……

实现代码如下:

Sub 条件汇总()
Dim Rule, Arr, Arrt, Arr2, Arr3, Result, Dic As Object, Dic2 As Object, Dic3 As Object, N&, I&, T&, Str$, Str2$
Rule = Split("a,,/,-,(,),", ",=,<,>,:,+,0,1,2,3,4,5,6,7,8,9,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,.", ",") '生成排序规则数组
Set Dic = CreateObject("scripting.dictionary") '创建字典项目,字典1和2用于保存前两位字符及序号,key与item相反,以方便进行反查,字典3用于统计最终结果
Set Dic2 = CreateObject("scripting.dictionary")
Set Dic3 = CreateObject("scripting.dictionary")
T = 1 '初始化序号为1
For N = Asc("A") To Asc("Z") '生成字符序列并保存对应序号
For I = LBound(Rule) To UBound(Rule)
Str = Chr(N) & Rule(I)
If Not Dic.exists(Str) Then
Dic(Str) = T
Dic2(CStr(T)) = Str
T = T + 1
End If
Next I
Next N
With ActiveSheet '针对活动工作表
Result = .[i1].Resize(.Cells(.Rows.Count, "I").End(3).Row, 5).Value '取得结果区内容存入数组中
For N = LBound(Result) + 1 To UBound(Result) '循环结果数据中各数据行
For I = LBound(Result, 2) To UBound(Result, 2) '循环结果数据各列
If I >= LBound(Result, 2) + 2 Then '结果数据区清0
Result(N, I) = 0
ElseIf I = LBound(Result, 2) Then '提取数据规则区位置规则内容拆分到数组中
Arr2 = Split(Replace(Result(N, I), " ", ""), "~")
Else '提取数据规则区分类号规则内容到数组中
Arr3 = Split(Replace(Result(N, I), " ", ""), "~")
End If
Next I
If Trim(CStr(Arr2(LBound(Arr2)))) = "0" Then '如果位置规则为0,则重置数组,分别写入起始号1和终止号9
ReDim Arr2(1 To 2)
Arr2(1) = 1
Arr2(2) = 9
Else '否则循环提取出规定的起止号
For I = LBound(Arr2) To UBound(Arr2) '循环位置数组各项
If Arr2(I) Like "[[{]*" Then Arr2(I) = Right(Arr2(I), Len(Arr2(I)) - 1) '判断是否有中括号或大括号,有则去除左侧括号(方便后面提取数值)
If Arr2(I) Like "*}*" Then '判断是否有右大括号存在,有则提取的值要减1
Arr2(I) = Val(Arr2(I)) - 1
Else
Arr2(I) = Val(Arr2(I))
End If
Next I
End If
For I = LBound(Arr3) To UBound(Arr3) '循环分类号数组各项
Arr3(I) = Replace(Arr3(I), " ", "") '替换掉可能存在的空格
If Arr3(I) Like "*[[]*" Then '判断是否有中括号,有则替换掉,并提取出对应的字典中序号存入数组当前项
Arr3(I) = Dic(Replace(Replace(Arr3(I), "[", ""), "]", ""))
ElseIf Arr3(I) Like "*[{]*" Then '判断是否有大括号,有则替换掉,并提取出对应的字典中序号减去1存入数组当前项
Arr3(I) = Dic(Replace(Replace(Arr3(I), "{", ""), "}", "")) - 1
Else '其他情况直接提取对应序号
Arr3(I) = Dic(Arr3(I))
End If
Next I
For I = Val(Arr2(LBound(Arr2))) To Val(Arr2(UBound(Arr2))) '循环生成所需结果,分类成数组方式存入字典3中
For T = Val(Arr3(LBound(Arr3))) To Val(Arr3(UBound(Arr3)))
Str = I & vbTab & Dic2(CStr(T)) '组合对应的位置及分类号头
If Dic3.exists(Str) Then '判断储存结果的字典3中是否存在,存在则将item项中数组提取出并添加进对应的结果数组中的行号
Arrt = Dic3(Str)
ReDim Preserve Arrt(LBound(Arrt) To UBound(Arrt) + 1)
Arrt(UBound(Arrt)) = N
Dic3(Str) = Arrt
Else '不存在时新建数组,写入行号并存为对应的item项
ReDim Arrt(1 To 1)
Arrt(1) = N
Dic3(Str) = Arrt
End If
Next T
Next I
Next N
Dic.RemoveAll '清空字典1和2
Dic2.RemoveAll
Arr = .[a1].Resize(.Cells(.Rows.Count, 2).End(3).Row, 5).Value '取得数据源中的数据
For N = LBound(Arr) + 1 To UBound(Arr) '循环数组源中的数据区各行
Arr(N, 2) = Left(Replace(Arr(N, 2), " ", ""), 2) '对数据进行整理,清除需判断内容中可能存在的空格
Arr(N, 4) = Trim(Arr(N, 4))
Str = Arr(N, 4) & vbTab & Left(Arr(N, 2), 1) '组合当前行图书的储存位置和分类号前一位
If IsArray(Dic3(Str)) Then '判断是否存在对应的字典项是否为数组(即是否属规则中需统计的内容),如果是,则
Arrt = Dic3(Str) '提取出对应的数组
For I = LBound(Arrt) To UBound(Arrt) '循环数组各项
If Len(Result(Arrt(I), 2)) = 1 Then '如果对应的结果数组中的规则字符长度为1(即需要统计所有以此字符开头且位置号对应的书籍),则
Result(Arrt(I), 3) = Result(Arrt(I), 3) + 1 '对应的册数加1
Dic(Arrt(I) & vbTab & vbTab & N) = "" '添加标识到字典中,防止重复统计
Result(Arrt(I), 5) = Result(Arrt(I), 5) + Arr(N, 5) '金额总数相加
Str2 = Arrt(I) & vbTab & vbTab & Trim(Arr(N, 3)) '组合结果表行号与书名
If Not Dic.exists(Str2) Then '判断是否存在对应字典项,以防止存书种类数重复统计
Result(Arrt(I), 4) = Result(Arrt(I), 4) + 1 '不存在时存书种类加1
Dic(Str2) = "" '添加对应标识
End If
End If
Next I
Dic(Str) = "" '已统计过内容添加标识到字典
End If
Str = Trim(Arr(N, 4)) & vbTab & Left(Arr(N, 2), 2) '组合位置和分类号前两位
If IsArray(Dic3(Str)) Then '判断是否存在对应的字典项是否为数组(即是否属规则中需统计的内容),如果是,则
Arrt = Dic3(Str) '提取出对应的数组
For I = LBound(Arrt) To UBound(Arrt) '循环数组各项
If Not Dic.exists(Arrt(I) & vbTab & vbTab & N) Then '如果该项未被统计过,则进行统计
Result(Arrt(I), 3) = Result(Arrt(I), 3) + 1
Result(Arrt(I), 5) = Result(Arrt(I), 5) + Arr(N, 5)
End If
Str2 = Arrt(I) & vbTab & vbTab & Trim(Arr(N, 3)) '组合结果行号和书名
If Not Dic.exists(Str2) Then '当对应内容未被统计过时
Result(Arrt(I), 4) = Result(Arrt(I), 4) + 1 '存书种类加1
Dic(Str2) = "" '添加标识
End If
Next I
End If
Next N
.[o1].Resize(UBound(Result), UBound(Result, 2)) = Result '全部统计完成后,向结果区写入结果数据
End With
Set Dic = Nothing '清空字典项目
Set Dic2 = Nothing
Set Dic3 = Nothing
End Sub

那么的帅 · 发表于 2012-4-13 09:03

谢谢楼主分享，花了楼主不少功夫，仔细研究一下。

auhl · 发表于 2012-4-13 09:09

谢谢楼主分享,学习一下

zmxncbv111 · 发表于 2013-7-17 22:01

谢谢楼主分享,学习一下

zmxncbv111 · 发表于 2013-7-17 22:01

		自动登录	找回密码
密码			注册

如何利用vba代码对特定排序规则条件区间内的图书内容进行统计?

相关帖子