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

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, j, a, n, arr
  arr = Range("a1:a" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  ReDim brr(1 To Rows.Count, 1 To 1)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If Len(arr(j, 1)) > 0 Then a = j: Exit For
    Next
    For j = a To UBound(arr, 1) - 1
      If Len(arr(j + 1, 1)) = 0 Then
        n = n + 1: brr(n, 1) = j - a + 1
        i = j: Exit For
      End If
  Next j, i
  With [d1]
    .Resize(Rows.Count).ClearContents
    If n > 0 Then .Resize(n) = brr
  End With
End Sub

lsdongjh

1. 
   
2. Sub Test()
   
3.     Dim lngRows As Long, lngRow As Long
   
4.     Dim arrSource As Variant, arrResult As Variant
   
5.     Dim strCurr As String, strPre  As String
   
6.     Dim lngCount As Long, lngID As Long
   
7.    
   
8.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
   
9.     arrSource = Sheet1.Range("A1:A" & lngRows)
   
10.    
    
11.     strPre = arrSource(1, 1)
    
12.     lngID = 0
    
13.     lngCount = 1
    
14.     ReDim arrResult(1 To 2, 1 To 1)
    
15.     For lngRow = 2 To lngRows
    
16.         strCurr = arrSource(lngRow, 1)
    
17.         If Trim(strPre) = "" And lngRow <> lngRows Then
    
18.             strPre = strCurr
    
19.             lngCount = 1
    
20.         Else
    
21.             If strCurr <> strPre Or lngRow = lngRows Then
    
22.                 lngID = lngID + 1
    
23.                 ReDim Preserve arrResult(1 To 2, 1 To lngID)
    
24.                 arrResult(1, lngID) = IIf(lngRow = lngRows, strCurr, strPre)
    
25.                 arrResult(2, lngID) = lngCount
    
26.                 strPre = strCurr
    
27.                 lngCount = 1
    
28.             Else
    
29.                 lngCount = lngCount + 1
    
30.             End If
    
31.         End If
    
32. 
    
33.     Next
    
34.    
    
35.     arrResult = Application.WorksheetFunction.Transpose(arrResult)
    
36.    
    
37.     Sheet1.Range("D1").Resize(UBound(arrResult), 2) = arrResult
    
38. End Sub
    

复制代码

闻风上胆

lsdongjh 发表于 2018-6-21 13:09

老师，能反向排列吗？这样不能计算

闻风上胆

一把小刀闯天下 发表于 2018-6-21 12:18
Option Explicit

Sub test()

老师，麻烦你反向排列，谢谢您 ！！

lsdongjh

闻风上胆 发表于 2018-6-21 14:08
老师，能反向排列吗？这样不能计算

什么意思？不明白你意思？

闻风上胆

lsdongjh 发表于 2018-6-21 14:09
什么意思？不明白你意思？

开始标错了，谢谢你老师！！

闻风上胆

lsdongjh 发表于 2018-6-21 14:09
什么意思？不明白你意思？

最下面连续次数放在最上面，依此类推！！谢谢！！

lsdongjh

1. Sub Test()
   
2.     myCount '无参数或参数为0 ,正序
   
3.    
   
4.    ' myCount 1 '参数非零，倒序
   
5. End Sub
   
6. 
   
7. 
   
8. Function myCount(Optional intDirection As Integer = 0)
   
9.     Dim lngRows As Long, lngRow As Long
   
10.     Dim arrSource As Variant, arrResult As Variant, arrTemp As Variant
    
11.     Dim strCurr As String, strPre  As String
    
12.     Dim lngCount As Long, lngID As Long
    
13.    
    
14.     lngRows = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    
15.     arrSource = Sheet1.Range("A1:A" & lngRows)
    
16.    
    
17.     strPre = arrSource(1, 1)
    
18.     lngID = 0
    
19.     lngCount = 1
    
20.     ReDim arrResult(1 To 2, 1 To 1)
    
21.     For lngRow = 2 To lngRows
    
22.         strCurr = arrSource(lngRow, 1)
    
23.         If Trim(strPre) = "" And lngRow <> lngRows Then
    
24.             strPre = strCurr
    
25.             lngCount = 1
    
26.         Else
    
27.             If strCurr <> strPre Then
    
28.                 lngID = lngID + 1
    
29.                 ReDim Preserve arrResult(1 To 2, 1 To lngID)
    
30.                 arrResult(1, lngID) = strPre
    
31.                 arrResult(2, lngID) = lngCount
    
32.                 strPre = strCurr
    
33.                 lngCount = 1
    
34.             Else
    
35.                 lngCount = lngCount + 1
    
36.             End If
    
37.             If lngRow = lngRows Then
    
38.                 ReDim Preserve arrResult(1 To 2, 1 To lngID + 1)
    
39.                 arrResult(1, lngID + 1) = strPre
    
40.                 arrResult(2, lngID + 1) = lngCount
    
41.             End If
    
42.         End If
    
43. 
    
44.     Next
    
45.    
    
46.     arrResult = Application.WorksheetFunction.Transpose(arrResult)
    
47.    
    
48.    
    
49.     If intDirection <> 0 Then
    
50.         arrTemp = arrResult
    
51.         lngID = UBound(arrTemp)
    
52.         For lngRows = LBound(arrTemp) To UBound(arrTemp)
    
53.             arrResult(lngID - lngRows + LBound(arrTemp), 1) = arrTemp(lngRows, 1)
    
54.         Next
    
55.     End If
    
56.    
    
57.     Sheet1.Range("D1").Resize(UBound(arrResult), 2) = arrResult
    
58. End Function
    

复制代码

闻风上胆

lsdongjh 发表于 2018-6-21 14:38

不对啊 老师。

闻风上胆

lsdongjh 发表于 2018-6-21 14:38

这样的，你再帮忙看看！！谢谢！！