利用VBA对重复列进行计数

hg65

有什么好的方法可以对A、B、C、D  4列内容完全重复的行，进行计数，计数结果填到E列；
数据量大，excel函数也能实现，但耗时长，利用字典我还不懂

Qs18

试试..............

扇扇扇

数组循环应该也行

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, r&, dic As Object, strJoin$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    r = Cells(Rows.Count, "A").End(xlUp).Row
    ar = Range("A2:D" & r).Value
   
    For i = 1 To UBound(ar)
        strJoin = Join(Application.Index(ar, i), "|")
        dic(strJoin) = dic(strJoin) + 1
    Next i
    For i = 1 To UBound(ar)
        strJoin = Join(Application.Index(ar, i), "|")
        ar(i, 1) = dic(strJoin)
    Next i
   
    [E2].Resize(UBound(ar)) = ar
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。。。。。

Qs18

Sub qs()
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1").CurrentRegion.Value
For i = 2 To UBound(arr)
    s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
    If Not dic.exists(s) Then
        dic(s) = 1
    Else
        dic(s) = dic(s) + 1
    End If
Next
For i = 2 To UBound(arr)
    s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
    arr(i, 5) = dic(s)
Next
Sheet1.Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
MsgBox "ok"
End Sub

Qs18

试试.......

rysxing

jsa，试试。。。。。。

hg65

Qs18 发表于 2024-8-29 20:10
试试..............

感谢，脚本挺好的，还能便于我在这基础上调整修改；

hg65

gwjkkkkk 发表于 2024-8-29 19:58
。。。。。。。。。。。。。。

这个也挺好，但老弟我有点看不懂，不会改