作者：绿色风
分类：
时间：2022-08-17
浏览：138
楼主
kevinchengcw |
Q: 如何用vba代码根据客户清单及表格特征对多个表格进行重新排序以方便打印？
A: 代码如下:
- Sub test()
- Dim Arr, N&, Str$, Str2$, Rng As Range, Ws As Worksheet
- With Worksheets("名单") '将名单区域装入数组
- Arr = Application.Transpose(.Cells(2, 1).Resize(.Cells(.Rows.Count, 1).End(3).Row - 1, 1))
- End With
- With Worksheets("源数据")
- For Each Ws In Worksheets '循环查找是否已有处理过的工作表，如果有先删除
- If Ws.Name = .Name & "排序后" Then
- Application.DisplayAlerts = False
- Ws.Delete
- Application.DisplayAlerts = True
- Exit For
- End If
- Next Ws
- Set Ws = Worksheets.Add '添加一个新的工作表
- Ws.Move after:=Worksheets(.Name) '新表移动到“源数据”表后
- Ws.Name = .Name & "排序后" '新表的表名为“源数据排序后”
- .Activate '激活源数据表进行操作
- For N = LBound(Arr) To UBound(Arr) '循环清单中各项
- .Cells(1, 1).Select '选定源表中的a1单元格
- Do '循环查找
- Set Rng = .Range(ActiveCell.Address, .Cells.Find("备注", ActiveCell).Offset(0, 7)) '设定单元格区域为活动单元格到活动单元格后面查找到的第一个单元格的A：G列的范围
- Str = Trim(Split(Rng.Find("收款人").Value, ":")(1)) '取得收款人后面对应的名称赋值给Str
- Str2 = Trim(Split(Rng.Find("付款人").Value, ":")(1)) '取得付款人后面对应的名称赋值给Str2
- If Str = Arr(N) Or Str2 = Arr(N) Then Rng.Copy Ws.Cells(1, 1).Offset(Ws.Cells(Ws.Rows.Count, 1).End(3).Row, 0) '如果收款人或付款人名存在于清单中，则将当前查找的范围复制到新表的数据区域下方（注意：利用copy方式是为了保持原有的数据结构及格式）
- .Cells.Find("备注", ActiveCell).Offset(1, 0).Select '选定当前活动单元格后查找到的第一个备注下方的单元格
- Loop While .Cells.Find("备注", ActiveCell).Row > ActiveCell.Row '继续循环，直到查找到的备注单元格的行号小于活动单元格，即数据区已循环完成
- Next N
- .Cells(1, 1).Select '选择a1单元格，回到数据区开头
- End With
- End Sub
注：本例中，未在清单中出现的公司的表将不会被复制。
思路分析：
取得清单列表，循环表格区域，利用每份表格结尾开头字符为"备注"这一特征，利用查找功能将表格分成数个区域，如果区域中关键位置的值与当前列表中循环到的值相同，则将当前区域复制到新表中，依此类推，将全部表格重新排序。
另一个进阶想法为，将表格区域查找后连同关键信息存入字典，然后再进一步处理，如此可以有更多高级功能，也可以克服本例中未在清单中出现的公司不会出现在新表里的缺点，有兴趣的网友可以自行研究一下。
附本例的示例文件。
 分类打印新_1.rar
|
2楼
い卋玑┾宝珼 |
学习了，挖到的K版的代码看完的速度比某七版时间多多了 |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一