[菜鸟笔记]用字典汇总一例

楼主 wjc2090742	要求：根据字段4、字段8，两者都相同的，汇总其字段7，并将page1表更新为汇总结果，然后将page1表、附件表拷贝到新工作簿，生成指定名称问题，并隐藏本表中page1、附件表俩表。第一次写注释，写个菜鸟笔记，留个纪念，高手莫笑。速度方面就不要太跟我计较了哈 Sub tt() t = Timer: m = 0 't用做计时，如果不需要知道程序运行时间，可删。初始化m，用于下面的ar，可放到下面 Application.ScreenUpdating = False '关闭屏幕刷新 Application.DisplayAlerts = False '关闭提示框，因为生成的文件有可能原来已存在，关闭后可以直接覆盖 Dim N% '定义N为短整，用于工作表计数 For N = Sheets.Count To 1 Step -1 '因为要删除page1表，此处反向循环。step -1表示步长为-1 Sheets(N).Visible = True '取消各表的隐藏 If Sheets(N).Name = "Page1" Then Sheets(N).Delete '删除原page1表，与原代码不同处。因为数量大时，整表数据复制会占据较多时间 Next Dim arr(), ar(), i&, di, dic, s$, str$ '定义相关变量。arr用于装sheet1中所有数据，ar用于装汇总后数据 Set di = CreateObject("Scripting.Dictionary") '创建字典，属后期绑定 Set dic = CreateObject("Scripting.Dictionary") '与上同。用2个字典，不好处是多了一个对象，好处是后期不用循环arr arr() = [a1].CurrentRegion.Value '给arr赋值。currentregion表示当前区域，即10版中选中a1，按ctrl+a选中区域 For i = 1 To UBound(arr, 1) '在arr中循环，i计数，ubound为数组上标，ubound中，1表示行上标，如果要表示列上标用2 s = arr(i, 4) & arr(i, 8) '将字段4、8连接为一个字符串s，用作di、dic的key If Not di.exists(s) Then 'exists方法，判断字典di中指定的关键字是否存在，存在返回true。not取反 di.Add s, arr(i, 7) '如果不存在，则di添加s为新key，对应item为字段7 str = "" '初始化str For j = 1 To 8 str = str & "★" & arr(i, j) '将字段1-8连接为1个字符串str，用作dic的item，中用某种符号隔开，对应下面split分解 Next dic.Add s, str 'dic添加s为新key，对应item为str,dic与di有同样的key Else '上句写在di中不存在s关键字条件下，因为只需要保留s第一次出现时的各字段内容 di(s) = di(s) + arr(i, 7) '当s关键字已存在，di中对应item累加字段7值 End If Next For Each k In di.keys '循环di中的key m = m + 1 '每循环一个key，m都+1，用作ar的第二维上标 ReDim Preserve ar(1 To 8, 1 To m) '重定义ar，能重定义的只有数组最后一维，preserve表示重定义时保留原有数据 kk = Split(dic(k), "★") 'split按照特定符号拆分dic中item为下标为0的一维数组 For j = 1 To 8 '循环，将split得到的字段1-8以及di中的item装入ar，此处至下面也可以1-8一行一行来写 If j = 4 Then If Val(kk(j)) Then 'val返回包含于字符串内的数字，如val("26dbd598")返回26598，判断字段4是否含有数字 ar(j, m) = "‘" & kk(j) '为了验证，这里用中文半角单引，用时可以自己修改 Else: ar(j, m) = kk(j) '如果不含有数字，则不加半引 End If ElseIf j = 7 Then ar(7, m) = di(k) 'j=7时，即字段7，从di的item取值 Else: ar(j, m) = kk(j) 'kk是一个一维数组，通过循环，将其装入ar中 End If Next Next Set di = Nothing: Set dic = Nothing '清除字典，释放内存 ActiveWorkbook.Sheets.Add '与上面删除page1表对应，sheets.add方法增加新工作表 With ActiveSheet .Name = "Page1" '新表默认名为sheetN，设置name属性，自定义工作表名 .[a1].Resize(UBound(ar, 2), 8) = WorksheetFunction.Transpose(ar) '将ar填入page1表中，调用工作表函数transpose转置ar End With With Workbooks.Add(xlWBATWorksheet) '创建新工作簿，括号中为XlWBATemplate常量，这里用的值表示创建的是工作表 ThisWorkbook.Sheets(Array("Page1", "附件表")).Copy After:=.Sheets(1) '将本工作簿中page1、附件表拷贝到新创建表中，位置在第1个表之后 .Sheets(1).Delete '删除第1个工作表 .SaveAs Filename:=ThisWorkbook.Path & "\导入标准凭证.xls" '另存为本工作簿所在目录下，名称为...的新文件 .Close '关闭新建工作簿 End With For N = Sheets.Count To 1 Step -1 If Sheets(N).Name <> "Sheet1" Then Sheets(N).Visible = xlSheetHidden '隐藏除sheet1之外的其它工作表 Next Application.DisplayAlerts = True '恢复提示框弹出设置，此处2句与上面关闭对应 Application.ScreenUpdating = True '恢复屏幕刷新 MsgBox "程序运行完成！" & Chr(10) & "全程历时：" & Timer - t & "秒！" & Chr(10) End Sub bb.rar
2楼纵鹤擒龙水中月	学习了
3楼 kangguowei	这么长.