如何利用vba代码对合并单元格区域进行排序(数据位置重排)？

楼主
kevinchengcw

Q: 如何利用vba代码对合并单元格区域进行排序(数据位置重排)？
A:代码如下：

Sub test()
Dim Dic As Object, Ws As Worksheet, N%, Rng As Range
Application.ScreenUpdating = False '因为涉及到很多单元格操作，所以关闭屏幕刷新以提高处理速度
Set Dic = CreateObject("scripting.dictionary") '创建字典对象，用于处理中数据的存储及提取
[b2].Select '选定起始单元格
Do While ActiveCell <> "" '当单元格内容不为空时循环（即未超出数据区范围，本例适用）
With Selection
For N = .Row To .Row + .Rows.Count - 1 '循环单元格区域的起始行到终止行（如果为合并单元格的话，该范围为多行，非合并单元格为一行）
If Cells(N, .Column + 1) = "易贴" Then Dic.Add ActiveCell.Value, ActiveCell.Offset(, 3).Value '根据楼主要求，判断含有"易贴"的数据，并提取对应的公司名（活动单元格内容）及价税合计数存入字典中
Next N
.Offset(1).Select '利用偏移指令移到下一个单元格并选定（如此可选定一个完整的合并单元格区域）
End With
Loop
If Dic.Count > 0 Then '完成数据区数据采集后，判断字典中是否有数据，如果执行下面操作
Set Ws = Worksheets.Add '添加一个工作表
N = Dic.Count '把字典的项目数指定给变量N
With Ws '在新添加的表中
.[a1].Resize(N, 1) = Application.Transpose(Dic.items) 'A列存放字典的item项（即价税合计数值）
.[b1].Resize(N, 1) = Application.Transpose(Dic.keys) 'B列存放字典的key项（即公司名）
.[a1].Resize(N, 2).Sort key1:=.[a1], Order1:=xlDescending '依据A列数据（价税合计数值）对数据区进行降序排列
For Each Rng In .[b1].Resize(N, 1) '循环B列数据区
Dic(Rng.Value) = Rng.Row '将对应字典项中公司名的item项替换成单元格的行数值（即排序序号）
Next Rng
Application.DisplayAlerts = False '禁止警告信息显示
.Delete '删除新添加的表
Application.DisplayAlerts = False '启用警告信息显示
End With
N = N + 1 '将字典项数值加1（目的：可能存在没有使用易贴的公司，我们将按照出现顺序为其排序，但就排在已排序的公司后面，所以从字典项数加1开始）
[b2].Select '再次选择起始单元格
Do While ActiveCell <> "" '循环写入对应序号
If Dic.exists(ActiveCell.Value) Then
ActiveCell.Offset(, -1) = Dic(ActiveCell.Value)
Else
ActiveCell.Offset(, -1) = N '如果当前公司未出现在字典中（即未使用易贴的公司），则其序号为N的值
N = N + 1 'N的值加1
End If
ActiveCell.Offset(1).Select '再下移一个单元格并选中
Loop
Dic.RemoveAll '清空字典项目，以方便后期用于存储单元格区域范围
[a2].Select '再次选择起始单元格
Do While ActiveCell <> "" '循环将以序号为key，以单元格对就区域范围为item，存入字典
Dic.Add CStr(ActiveCell.Value), ActiveCell.Resize(Selection.Rows.Count, 5).Address
ActiveCell.Offset(1).Select
Loop
[h2].Select '选择一个临时区域的起始地址，用于重级数据
For N = 1 To Dic.Count '利用序号循环，提取出对应的数据区数据
Range(Dic(CStr(N))).Copy ActiveCell '将对应的数据区复制到临时区域（注意：是以序号顺序）
ActiveCell.Offset(1).Select '粘贴后单元格下移，即新数据区下方第一个未使用单元格位置
Next N
[a2].Resize(Cells(Rows.Count, 5).End(3).Row - 1, 7).Delete 1 '删除旧数据区域，并全临时数据区位于旧数据区原位置
End If
Set Dic = Nothing '清空字典
Application.ScreenUpdating = True '打开屏幕刷新
MsgBox "排序完成！" '显示提示信息
End Sub

以上除代码操作外，其余全部利用工作表即有功能实现。

2楼
xyf2210

谢谢分享