楼主
LOGO |
如下图所示，如何将左侧数据去重并以右侧形式返回结果?
代码如下：
- Sub 数据去重并作结构转换()
- '声明变量
- Dim 数据 '要处理的数据
- Dim 关键字 '字典的关键字
- Dim 项目 '字典的项目
- Dim 辅助 '辅助数组
- Dim 结果 '结果数组
- Dim 字典 As Object '字典对象
- Dim i As Integer '
- Dim y As Integer
- Dim 列数 As Integer '结果数组列数
- Dim 行数 As Integer '结果数组行数
- '变量赋值
- 数据 = Range("A1").CurrentRegion '将要处理的数据写入数组
- Set 字典 = CreateObject("scripting.dictionary") '引用vbs字典
- 字典(数据(2, 1)) = "," & 数据(2, 2) & "," '将数据数组第一条记录先写入字典(双边加逗号是为了下面项目是否添加作准备)
-
- '提速语句
- Application.ScreenUpdating = False
- Application.Calculation = xlCalculationManual
-
- For i = 3 To UBound(数据) '将第二条记录起至最后一条记录写入字典
- If 字典(数据(i, 1)) = "" Then '如果字典关键字中不存在当前记录
- 字典(数据(i, 1)) = "," & 数据(i, 2) & "," '那么将该对数据写入字典(字典都是成对的，关键字+项目)
- Else '如果字典中已经存在该数据（关键字)，那么再做进一步判断
- If InStr(字典(数据(i, 1)), "," & 数据(i, 2) & ",") Then '如果该关键字的项目中已经存在了
- 字典(数据(i, 1)) = 字典(数据(i, 1)) '那么项目不作添加
- Else '否则在原有项目的基础上添加当前数据，并且用逗号隔开
- 字典(数据(i, 1)) = 字典(数据(i, 1)) & 数据(i, 2) & "," '
- End If
- End If
- Next i '处理数据中的下一行数据
- ' Stop
- 关键字 = 字典.keys '将字典的关键字写入数组-关键字
- 项目 = 字典.items '将字典的项目写入数组-项目
-
- '由于上面为了instr时实现精确查找，所以在项目的两端都添加了逗号，所以现在要把项目两端的逗号给去掉
- For i = 1 To 字典.Count
- 项目(i - 1) = Mid(项目(i - 1), 2, Len(项目(i - 1)) - 2)
- Next i
- ' Stop
-
- 行数 = 字典.Count '确定结果数组的行数(与字典的关键字个数一样)
-
- ReDim 辅助(1 To 行数) '定义辅助数组的大小(要将项目数组的每个数据用split根据分隔符号(,)来拆分，然后将其存放到辅助数组中去，形成数组中的数组)
- 辅助(1) = Split(项目(0), ",") '先将项目数组的第一个数据用split拆分然后放到辅助数组中去
- 列数 = UBound(辅助(1)) '获取辅助数组第一个数据（是一个数组)的下标数(因为下一步要通过循环来获取辅助数组各数据中下标最大者，将其下标
- For i = 1 To UBound(项目) '+2作为结果数组的列数(+2的原因：split产生的数组下标从0开始,所以要+1,另外结果中还要多一列（字典中的关键字),所以还要+1)
- 辅助(i + 1) = Split(项目(i), ",") '依次将项目用split拆分后放到辅助数组中去
- If UBound(辅助(i)) > 列数 Then 列数 = UBound(辅助(i)) '循环比较辅助数组内各数组的下标，获取最大者以便进一步确定辅助数组的列数
- Next i
-
- ReDim 结果(1 To 行数 + 1, 1 To 列数 + 2) '定义结果数组的行数(行数+1是因为要写入标题)，列数
-
- '写入结果数组第一行各列数据
- 结果(1, 1) = 数据(1, 1) '第1行第1列写入数据数组的第1行第1列的标题
- For i = 2 To UBound(结果, 2) '第1行第2列至最后一列写入列名(原数据第1行第2列的标题+数字:如结果1、结果2、、、、）
- 结果(1, i) = 数据(1, 2) & i - 1
- Next i
- ' Stop
- '写入结果数组第1列第2行至最后一行的数据(这里要写入的是字典的关键字)
- For i = 2 To UBound(结果)
- 结果(i, 1) = 关键字(i - 2) '关键字数组的下标是从0开始的，所以要-2
- Next i
-
- '写入结果数组除第1行和第一列外的其他数据(即辅助数组中的数据)
- '
- For i = 1 To UBound(辅助)
- For y = 0 To UBound(辅助(i))
- 结果(i + 1, y + 2) = 辅助(i)(y)
- Next y
- Next i
-
- '将结果数组写入单元格
- With Range("E1") '写入起点设为E1
- .CurrentRegion.Clear '写入前先清除该一片区域原有数据
- .Resize(UBound(结果), UBound(结果, 2)) = 结果 '写入结果
- With .CurrentRegion
- .EntireColumn.AutoFit
- .Borders.LineStyle = xlContinuous
- End With
- End With
- '恢复屏幕更新和自动重算，以免影响正常工作
- Application.ScreenUpdating = True
- Application.Calculation = xlCalculationAutomatic
- End Sub
 数据附件.rar
|