求助：根据型号合并的问题

xiaozhiyouxi

从左边的内容变成右边的内容，实际左边的数量有很多的。有没有什么办法可以操作一下？请帮忙看看，谢谢！

microyip

字典去重即可

3190496160

Sub test()
With Sheet1
    Set d = CreateObject("scripting.dictionary")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:b" & r)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            If Not d.exists(Trim(ar(i, 1))) Then
                d(Trim(ar(i, 1))) = ar(i, 2)
            Else
               d(Trim(ar(i, 1))) = d(Trim(ar(i, 1))) & "," & ar(i, 2)
            End If
        End If
    Next i
    rs = .Cells(Rows.Count, 5).End(xlUp).Row + 2
    .Range("e2:f" & rs) = Empty
    .[e2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End With
   
End Sub

3190496160

shili.rar (15.69 KB, 下载次数: 5)

2020-5-31 09:47 上传

点击文件名下载附件

microyip

3190496160 发表于 2020-5-31 09:46
Sub test()
With Sheet1
    Set d = CreateObject("scripting.dictionary")

给个建议，用个变量来记录关键字vKey=Trim(ar(i, 1))，那么后面写码也简易了、清晰明了了，代码执行效率相对高了

笨鸟飞不高

Sub AwTest()
    Dim i%, arr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    arr = [a1].CurrentRegion
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            d(arr(i, 1)) = arr(i, 2)
        Else
            d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
        End If
    Next
    [h1].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub

笨鸟飞不高

Sub AwTest2()
    Dim i%, k%, m%, arr, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    arr = [a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            k = k + 1
            d(arr(i, 1)) = k
            d(arr(i, 1) & arr(i, 2)) = ""
            brr(k, 1) = arr(i, 1)
            brr(k, 2) = arr(i, 2)
        Else
            m = d(arr(i, 1))
            If Not d.exists(arr(i, 1) & arr(i, 2)) Then
                brr(m, 2) = brr(m, 2) & "," & arr(i, 2)
            End If
        End If
    Next
    [k1].Resize(k, 2) = brr
End Sub

值去重复！！

xiangbaoan

Option Explicit
Sub test()
Dim ar, d As Object, i&, j&, k&, s$, y&
Set d = CreateObject("Scripting.Dictionary")
ar = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
k = 1
For i = 2 To UBound(ar)
    s = ar(i, 1)
    If Not d.Exists(s) Then
        k = k + 1
        For j = 1 To 2
            ar(k, j) = ar(i, j)
        Next
        d(s) = k
    Else
        y = d(s)
        ar(y, 2) = ar(y, 2) & "," & ar(i, 2)
    End If
Next
With Range("e1")
    .CurrentRegion.ClearContents
    .Resize(k, 2) = ar
End With
Set d = Nothing
End Sub

duquancai

又是一个分组聚合，split    apply     combine    三板斧

microyip

duquancai 发表于 2020-5-31 11:14
又是一个分组聚合，split    apply     combine    三板斧

程咬金再现？