使用VBA批量查找信息并合并单元格

像风一样飞舞

各位大神，遇到一个Excel问题：
    在做统计的时候，往往有些备注，但是同一个型号的产品往往有多个备注，导出的格式如图片1，也可以见如下：

编号	客户特殊要求
A1	1米
A1	不切除
A1	1米
A1	1米
A2	2米
A2	1米
A2	不切除
A2	2米
A2	1米
A2	1米
A3	2米
A3	2米
A3	不切除
A3	不切除
A3	不切除
A3	不切除

目前需要使用VBA批量的获取产品A1-A3的全部备注信息，并在一个单元格中显示，如下：

需要结果
A1	1米；不切除
A2	2米；1米；不切除
A3	2米；不切除

说明：比如A1中，一共有多个“1米”的备注，相同的备注需要合并，无需重复提取内容，除了“1米”的备注外，另外还有一个“不切除”的备注，因此最终结果显示为：“1米；不切除”。

不知道哪位大神，可以使用VBA解决这个问题，多谢多谢！

魂断蓝桥

Sub a()
Dim arr, brr(1 To 999, 1 To 2), i%, m%, d, s, crr(1 To 999, 1 To 2), t%
Set d = CreateObject("Scripting.Dictionary")
arr = [c7].CurrentRegion
For i = 2 To UBound(arr)
    s = arr(i, 1) & arr(i, 2)
    If Not d.exists(s) Then
        m = m + 1
        brr(m, 1) = arr(i, 1)
        brr(m, 2) = arr(i, 2)
        d(s) = ""
    End If
Next
d.RemoveAll
For i = 1 To m
    If Not d.exists(brr(i, 1)) Then
        t = t + 1
        crr(t, 1) = brr(i, 1)
        crr(t, 2) = brr(i, 2)
        d(brr(i, 1)) = t
    Else
        crr(d(brr(i, 1)), 2) = crr(d(brr(i, 1)), 2) & "；" & brr(i, 2)
    End If
Next
[i12].Resize(t, 2) = crr
Set d = Nothing
End Sub

liujialin0o0

1. Sub tt()
   
2. Dim d As Object, c As Object
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set c = CreateObject("scripting.dictionary")
   
5. 
   
6. Set arr = [C8:C23]
   
7. For Each Rng In arr
   
8.     d(Rng.Value) = Rng.Offset(0, 1).Value
   
9. Next
   
10. 
    
11. [I8].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
12. 
    
13. Set brr = Range(Cells(8, 9), Cells(7 + d.Count, 9))
    
14. For Each rn In brr
    
15.     For Each Rng In arr
    
16.         If Rng = rn Then
    
17.             c(Rng.Offset(0, 1).Value) = ""
    
18.         End If
    
19.     Next
    
20.     rn.Offset(0, 1) = Join(c.keys, ";")
    
21.     c.RemoveAll
    
22. Next
    
23. End Sub

复制代码

像风一样飞舞

魂断蓝桥 发表于 2018-8-28 15:39
Sub a()
Dim arr, brr(1 To 999, 1 To 2), i%, m%, d, s, crr(1 To 999, 1 To 2), t%
Set d = CreateObje ...

请收下我的膝盖

像风一样飞舞

liujialin0o0 发表于 2018-8-28 16:21

高手辈出！高手高手高手，膜拜！

像风一样飞舞

liujialin0o0 发表于 2018-8-28 16:21

For Each Rng In arr
    d(Rng.Value) = Rng.Offset(0, 1).Value
这个语句中，如果我把D列数据移到A列（D列清空），并且将语句修改成：  d(Rng.Value) = Rng.Offset(0, -2).Value，为什么就运算不出来？

liujialin0o0

像风一样飞舞 发表于 2018-8-30 17:27
For Each Rng In arr
    d(Rng.Value) = Rng.Offset(0, 1).Value
这个语句中，如果我把D列数据移到A列 ...

For Each rn In brr
    For Each Rng In arr
        If Rng = rn Then
            c(Rng.Offset(0, -2).Value) = ""
        End If
    Next

改这里的