用VB统计重复时间的个数

夏日生花

请大侠用VB统计重复时间的个数，谢谢。

剑指E

1. Private Sub CommandButton1_Click()
   
2.     Dim d As Object, ar, br(), i&, c
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     ar = Range([g2], Cells(Rows.Count, 7).End(xlUp))
   
5.     For Each c In ar
   
6.         d(c) = d(c) + 1
   
7.     Next
   
8.     ReDim br(1 To UBound(ar), 1 To 1)
   
9.     For Each c In ar
   
10.         i = i + 1
    
11.         If d(c) > 1 Then br(i, 1) = d(c)
    
12.     Next
    
13.     Cells(2, 19).Resize(i) = br
    
14. End Sub

复制代码

.           

3190496160

Sub 去重复()
Dim ar As Variant, br As Variant
Dim arr()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 7).End(xlUp).Row
    .Range("s2:s" & r) = ""
    ar = .Range("g1:s" & r)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            d(ar(i, 1)) = d(ar(i, 1)) + 1
            If dc(ar(i, 1)) = "" Then
                dc(ar(i, 1)) = i
            Else
                dc(ar(i, 1)) = dc(ar(i, 1)) & "," & i
            End If
        End If
    Next i
    For Each k In dc.keys
        zd = dc(k)
        sl = d(k)
        If sl > 1 Then
            rr = Split(zd, ",")
            For i = 0 To UBound(rr)
                xh = rr(i)
                ar(xh, 13) = sl
            Next i
        End If
    Next k
    .Range("s1:s" & r) = Application.Index(ar, 0, 13)
End With
MsgBox "ok!"
End Sub

3190496160

统计重复时间的个数.rar (13.97 KB, 下载次数: 5)

2023-10-28 09:32 上传

点击文件名下载附件

3190496160

caiyu93

统计重复时间的个数.rar (15.87 KB, 下载次数: 4)

2023-10-28 09:47 上传

点击文件名下载附件

无关岁月

副本统计重复时间的个数.7z (11.1 KB, 下载次数: 5)

2023-10-28 09:51 上传

点击文件名下载附件

咔咔乱坠

函数，供参考..
溢出

=TEXT(COUNTIF(G2:G50,G2:G50),"[=1]""""")
下拉

=TEXT(COUNTIF(G$2:G$50,G2),"[=1]""""")

titi012

1. Sub 统计重复个数()
   
2. 
   
3.     Dim Dic As Object
   
4.     Set Dic = CreateObject("scripting.dictionary")
   
5.    
   
6.     Dim SjArr, nArr()
   
7.     SjArr = Range("G2:G" & [G65536].End(xlUp).Row).Value
   
8.     ReDim nArr(1 To UBound(SjArr))
   
9.    
   
10.     Dim x%
    
11.     For x = 1 To UBound(SjArr)
    
12.         Dic(Int(SjArr(x, 1))) = Dic(Int(SjArr(x, 1))) + 1
    
13.     Next x
    
14.    
    
15.     For x = 1 To UBound(SjArr)
    
16.         nArr(x) = Replace(Dic(Int(SjArr(x, 1))), 1, "")
    
17.     Next x
    
18.    
    
19.     Range("S2").Resize(UBound(SjArr), 1) = Application.WorksheetFunction.Transpose(nArr)
    
20.    
    
21. 
    
22. End Sub

复制代码

zhangcheng6688

来学习一下
arr = Range("g2:s" & Cells(Rows.Count, "g").End(xlUp).Row)
For i = 1 To UBound(arr)
     For j = 1 To UBound(arr)
          If arr(i, 1) = arr(j, 1) Then
             bz = bz + 1
          End If
     Next
     If bz = 1 Then
          arr(i, 13) = ""
     Else
          arr(i, 13) = Val(arr(i, 13)) + bz
     End If
     bz = 0
Next
[g2].Resize(UBound(arr), UBound(arr, 2)) = arr