用VBA数组或字典计算A列数字数字连续次数

laoau128

用VBA数组或字典计算A列数字数字连续次数

linyh1742595842

Sub cfz()
    Dim i&, Myr&, Arr
    Dim d, k, t
    Set d = CreateObject("Scripting.Dictionary")
    Myr = Sheet1.[a65536].End(xlUp).Row
    Arr = Sheet1.Range("a1:b" & Myr)
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = d(Arr(i, 1)) + 1
    Next
    k = d.keys
    t = d.items
    [c1].Resize(d.Count, 1) = Application.Transpose(k)
    [d1].Resize(d.Count, 1) = Application.Transpose(t)
    Set d = Nothing
End Sub

laoau128

linyh1742595842 发表于 2017-6-21 08:15
Sub cfz()
    Dim i&, Myr&, Arr
    Dim d, k, t

果然高手了，这2条如何做


http://club.excelhome.net/thread-1353146-1-1.html

用VBA数组或字典把F列一万行填充颜色



http://club.excelhome.net/thread-1353152-1-1.html

用VBA数组或字典挑选相同

lsdongjh

二楼的算法有问题，这不是算连续的，是计算某个数字出现的次数，与是否连续无关

laoau128

lsdongjh 发表于 2017-6-21 08:52
二楼的算法有问题，这不是算连续的，是计算某个数字出现的次数，与是否连续无关

你说的对，他的方法确实有问题，你有何计算方法

linyh1742595842

lsdongjh 发表于 2017-6-21 08:52
二楼的算法有问题，这不是算连续的，是计算某个数字出现的次数，与是否连续无关

请高手出招吧，没有看清楚要求，以为是计数出现的次数。

laoau128

linyh1742595842 发表于 2017-6-21 09:06
请高手出招吧，没有看清楚要求，以为是计数出现的次数。

你这个确实错了，

Sub 看这个()
    arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    k = 1
    For i = 2 To UBound(arr)
        If arr(i, 1) = arr(i - 1, 1) Then
            k = k + 1
        Else
            If d(arr(i - 1, 1)) < k Then d(arr(i - 1, 1)) = k
            k = 1
        End If
    Next
    If d(arr(i - 1, 1)) < k Then d(arr(i - 1, 1)) = k
    [c1].Resize(d.Count) = Application.Transpose(d.keys)
    [d1].Resize(d.Count) = Application.Transpose(d.items)
End Sub

awsa888

仅供参考~~~~~~~~~~~~~~~~~~~~~

lsdongjh

1. 
   
2. Sub Test()
   
3.     Dim lngI As Long
   
4.     Dim lngRows As Long
   
5.     Dim arr As Variant
   
6.     Dim objDic As Object
   
7.     Dim strKeys As Variant, strItems As Variant
   
8.     Dim arrResult As Variant
   
9.    
   
10.     Set objDic = CreateObject("Scripting.Dictionary")
    
11.    
    
12.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    
13.     arr = Sheet1.Range("A1:A" & lngRows)
    
14.    
    
15.     For lngI = 1 To UBound(arr)
    
16.         '记录行号
    
17.         objDic(arr(lngI, 1)) = objDic(arr(lngI, 1)) & "," & lngI
    
18.     Next
    
19.    
    
20.     strKeys = objDic.keys
    
21.     strItems = objDic.items
    
22.     lngRows = objDic.Count
    
23.    
    
24.     ReDim arrResult(1 To lngRows, 1 To 2)
    
25.    
    
26.     For lngI = 0 To lngRows - 1
    
27.         arrResult(lngI + 1, 1) = strKeys(lngI)
    
28.         arrResult(lngI + 1, 2) = CountContinuity(CStr(strItems(lngI)))
    
29.     Next
    
30.    
    
31.    
    
32.     Sheet1.Range("C1").Resize(lngRows, 2) = arrResult
    
33. End Sub
    
34. 
    
35. 
    
36. Function CountContinuity(strVal As String) As Long
    
37.     Dim strT() As String
    
38.     Dim lngMaxID As Long, lngI As Long
    
39.     Dim strContinuity As String, strFind As String
    
40.     Dim lngContinuity As Long
    
41.    
    
42.     strT = Split(strVal, ",")
    
43.     lngMaxID = UBound(strT)
    
44.    
    
45.     If lngMaxID = 1 Then
    
46.         CountContinuity = 1
    
47.         Exit Function
    
48.     End If
    
49.    
    
50.     For lngI = 2 To lngMaxID
    
51.         strContinuity = strContinuity & Val(strT(lngI)) - Val(strT(lngI - 1))
    
52.     Next
    
53.    
    
54.     lngContinuity = 1
    
55.     For lngI = lngMaxID - 1 To 1 Step -1
    
56.         strFind = String(lngI, "1")
    
57.         If InStr(strContinuity, strFind) > 0 Then
    
58.             lngContinuity = lngI + 1
    
59.             Exit For
    
60.         End If
    
61.     Next
    
62.    
    
63.     CountContinuity = lngContinuity
    
64.    
    
65. End Function

复制代码

运行效果如下：

laoau128

awsa888 发表于 2017-6-21 09:45
仅供参考~~~~~~~~~~~~~~~~~~~~~

等有分再加