求教：： 查找相同序列号对应的内容后排列：：

wbgogo

查找相同序列号对应的内容后按重复次数排列出来。

详见附件！  谢谢！

三分醉，七分醒

看不懂                                

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    r = Cells(Rows.Count, 3).End(3).Row
    arr = [a1].Resize(r, 10)
    For j = r To 8 Step -1
        str1 = arr(j, 8) & "#" & arr(j, 9) & "#" & arr(j, 10)
        d.RemoveAll
        For j1 = j - 1 To 8 Step -1
            If str1 = arr(j1, 8) & "#" & arr(j1, 9) & "#" & arr(j1, 10) Then
                For i = 3 To 6
                    d(arr(j1, i)) = d(arr(j1, i)) + 1
                Next i
            End If
        Next j1
        If d.Count > 0 Then
            brr = d.keys
            crr = d.items
            For n = 0 To UBound(crr)
                For m = n + 1 To UBound(crr)
                    If crr(m) > crr(n) Then
                        tm = crr(n)
                        crr(n) = crr(m)
                        crr(m) = tm
                        
                        tm = brr(n)
                        brr(n) = brr(m)
                        brr(m) = tm
                    End If
                Next m
            Next n
            Cells(j, 24).Resize(1, UBound(brr) + 1) = brr
        End If
    Next j
End Sub

liulang0808

附件内容供参考。。。。。

wbgogo

liulang0808 发表于 2023-4-25 12:56
Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    r = Cells(Rows.Count, 3).En ...

多谢刘版主！  
请问这一句    str1 = arr(j, 8) & "#" & arr(j, 9) & "#" & arr(j, 10)  要是根据需要扩展 序列号的范围怎么简化呀？  现在是3列还好，，， 要是几十列的序列号用这方式后边加起来有点费劲。
如何简化？

liulang0808

wbgogo 发表于 2023-4-25 14:04
多谢刘版主！  
请问这一句    str1 = arr(j, 8) & "#" & arr(j, 9) & "#" & arr(j, 10)  要是根据需要 ...

for循环组合到一起。。。

wbgogo

20列 6千多行的数据快跑不动了。。。  有没有高手大神。。。  速度快些的代码？ 求教了。