提取同一类数据存放到一个单元格换行并以序号排列

灬_锦。·°

各位大师帮忙看一下，以B列数据区分，如果B列对应的数字一样，将对应的G内容合并存放一起以12345...序号连接起来，需要的效果放到o列了，麻烦大师帮忙看看，因为数据较多，删除了部分内容 1一同一板内容汇总.zip (14.79 KB, 下载次数: 20)

2022-5-7 10:06 上传

点击文件名下载附件

山菊花

Sub cfz()
    Dim i&, Myr&, Arr, xh%
    Dim d, d2
    Set d = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Myr = Sheets("Sheet1").Cells(Rows.Count, 4).End(xlUp).Row
    Arr = Sheets("Sheet1").Range("b4:G" & Myr)
    For i = 1 To UBound(Arr)
        If Not d.exists(Arr(i, 1)) Then
            d2(Arr(i, 1)) = 1
            d(Arr(i, 1)) = "1、" & Arr(i, 6)
        Else
            xh = d2(Arr(i, 1)) + 1
            d2(Arr(i, 1)) = xh
            d(Arr(i, 1)) = d(Arr(i, 1)) & vbCrLf & xh & "、" & Arr(i, 6)
        End If
    Next
    Sheets("Sheet1").[K4].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    Set d = Nothing
    Set d2 = Nothing
End Sub

灬_锦。·°

山菊花 发表于 2022-5-7 14:33
Sub cfz()
    Dim i&, Myr&, Arr, xh%
    Dim d, d2

谢谢总版主，厉害厉害