[已解决]用VBA数组或字典计算A列数字数字连续次数

laoau138

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

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-6-22 12:55

1. Sub aaa()
   
2. Dim arr, i&, brr, r&
   
3. arr = [a1].CurrentRegion
   
4. ReDim brr(1 To UBound(arr), 1 To 2)
   
5. r = 1: brr(r, 1) = arr(1, 1): brr(r, 2) = 1
   
6. For i = 1 To UBound(arr) - 1
   
7.   If arr(i, 1) <> arr(i + 1, 1) Then
   
8.     r = r + 1
   
9.     brr(r, 1) = arr(i + 1, 1)
   
10.     brr(r, 2) = 1
    
11.   Else
    
12.     brr(r, 2) = brr(r, 2) + 1
    
13.   End If
    
14. Next i
    
15. [c10].Resize(r, 2) = brr
    
16. End Sub

复制代码

跳转到最佳答案楼层

idnoidno

1. Sub ts()
   
2. Dim dic As Object
   
3. Dim i As Integer
   
4. Dim arr
   
5. 
   
6. arr = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row)
   
7. Set dic = CreateObject("scripting.dictionary")
   
8. For i = 1 To UBound(arr)
   
9.     If Not dic.exists(dic(arr(i, 1))) Then
   
10.         dic(arr(i, 1)) = dic(arr(i, 1)) + 1
    
11.     End If
    
12. Next i
    
13. [c1].Resize(dic.Count) = Application.Transpose(dic.keys)
    
14. [d1].Resize(dic.Count) = Application.Transpose(dic.items)
    
15. Set dic = Nothing
    
16. End Sub

复制代码

應該是我跟您學習吧

laoau138

idnoidno 发表于 2017-6-21 12:51
應該是我跟您學習吧

你这个代码是错误的，首先理解一下什么叫做连续


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

大灰狼1976

laoau138 发表于 2017-6-21 13:32
你这个代码是错误的，首先理解一下什么叫做连续

连续出现次数确认一下，如果一个数字在两处（连续）出现，那么连续次数是取较多的一次？还是分别统计？

laoau138

大灰狼1976 发表于 2017-6-22 09:13
连续出现次数确认一下，如果一个数字在两处（连续）出现，那么连续次数是取较多的一次？还是分别统计？

如果一个数字在两处（连续）出现        最好分别计算，

例如
1
1
3
1
1
1

那么1  连续2
       3  连续1
       1  连续3
   


原来这个代码计算最大连续了

大灰狼1976

1. Sub aaa()
   
2. Dim arr, i&, brr, r&
   
3. arr = [a1].CurrentRegion
   
4. ReDim brr(1 To UBound(arr), 1 To 2)
   
5. r = 1: brr(r, 1) = arr(1, 1): brr(r, 2) = 1
   
6. For i = 1 To UBound(arr) - 1
   
7.   If arr(i, 1) <> arr(i + 1, 1) Then
   
8.     r = r + 1
   
9.     brr(r, 1) = arr(i + 1, 1)
   
10.     brr(r, 2) = 1
    
11.   Else
    
12.     brr(r, 2) = brr(r, 2) + 1
    
13.   End If
    
14. Next i
    
15. [c10].Resize(r, 2) = brr
    
16. End Sub

复制代码