楼主
DJ_Soo |
Q：有两列数据,第一列有很多重复如"A,B,C,A,C"等,第二列有不同信息,如何将所有第一列相同的内容合并为一个,并将对应第二列的内容整合在一起,并显示整合后的结果?
A：ALT+F11→VBE编辑环境→右键插入模块→输入以下代码:- Option Explicit
- Sub Unique_Merge()
- Dim arrKeys As Variant
- Dim arrCon As Variant
- Dim arrRes As Variant
- Dim lstRo As Long
- With ThisWorkbook
- With .Sheets(1)
- lstRo = .Cells(Rows.Count, 1).End(xlUp).Row
- arrKeys = .[A1].Resize(lstRo)
- arrCon = .[B1].Resize(lstRo)
- End With
- arrRes = Unique_Merge_2(arrKeys, arrCon)
- With .Sheets(2).[A1].Resize(UBound(arrRes), 2)
- .EntireRow.ClearContents
- .Value = arrRes
- .Parent.Activate
- End With
- End With
- End Sub
- Function Unique_Merge_2(arr_Keys As Variant, arr_Con As Variant)
- Dim Dic As Object '字典
- '注:Key理解为正常我们查字典中的字,如"爱"
- Dim Keys As Variant '数组,装载已经unique的Keys
- Dim Con As String '按照字典查字的理解,此处Con为对应字义,如爱的字义有"喜欢"和"同情"等不同解释
- '数值(字典对应的字义),此函数为多种字义给合并起来,并以换行符分隔
- Dim arrKeys As Variant '***此处两个数组arrKeys和arrCon***************
- Dim arrCon As Variant '***定义出来是为了适应在工作表中直接引用单元格**
- Dim arrRes() As Variant '********************************************
-
- Dim Ro As Long
- Dim fstRo As Long '为适应多种数组,此处设置fstRo以便自动调整(但要求arrKeys,arrCon相同结构!)
- Dim lstRo As Long
- Dim cntKeys As Long 'unique之后keys的个数
- Dim Cnt As Long
-
- Set Dic = CreateObject("Scripting.dictionary") '创建字典
- arrKeys = arr_Keys: arrCon = arr_Con '避免遇到range类型出错
- fstRo = LBound(arrKeys): lstRo = UBound(arrKeys)
- For Ro = fstRo To lstRo
- Con = Dic(arrKeys(Ro, 1))
- If Con = "" Then '判断是否曾经有过字义内容
- Dic(arrKeys(Ro, 1)) = arrCon(Ro, 1)
- Else
- Dic(arrKeys(Ro, 1)) = Con & vbNewLine & arrCon(Ro, 1)
- End If
- Next Ro
- cntKeys = Dic.Count: Keys = Dic.Keys 'unique之后指定给keys数组
- ReDim arrRes(1 To cntKeys, 1 To 2) '不用指定类型是为了适应多种类型
- For Cnt = 1 To cntKeys
- arrRes(Cnt, 1) = Keys(Cnt - 1) '列举字典中所有的字
- arrRes(Cnt, 2) = Dic(Keys(Cnt - 1)) '对应字义的合并
- Next Cnt
- Unique_Merge_2 = arrRes
- End Function
整合前数据类型:
整合后数据类型:
 字典应用(唯一整合).rar
|
