VBA截取A列计算五种属性最大连续

laoau138

VBA截取A列计算五种属性最大连续

grf1973

简单的就不解释了。

1. Sub grf()
   
2.     arr = Range("a1:a" & [a65536].End(3).Row)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 1 To UBound(arr)
   
5.         x = Left(arr(i, 1), 1) & Mid(arr(i, 1), 3, 1)
   
6.         If Not d.exists(x) Then
   
7.             d(x) = 1: p = 1
   
8.         Else
   
9.             y = Left(arr(i - 1, 1), 1) & Mid(arr(i - 1, 1), 3, 1)
   
10.             If y = x Then
    
11.                 p = p + 1
    
12.                 If p > d(x) Then d(x) = d(x) + 1
    
13.             Else
    
14.                 p = 1
    
15.             End If
    
16.         End If
    
17.     Next
    
18.     [b7].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
19. End Sub
    

复制代码

雄鹰2013

Sub 雄鹰()
Dim arr
Set d = CreateObject("scripting.dictionary")
arr = Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
ReDim brr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
     t = Mid(arr(i, 1), 1, 1) & Mid(arr(i, 1), 3, 1)
     If t <> "" And Not d.exists(t) Then n = n + 1: d(t) = n: brr(n, 1) = t
Next i
For Each k In d.keys
     s = 0
     For i = 1 To UBound(arr)
         t = Mid(arr(i, 1), 1, 1) & Mid(arr(i, 1), 3, 1)
         If k = t Then
            m = m + 1
         Else
            If m > s Then s = m
            m = 0
         End If
     Next i
     brr(d(k), 2) = s
Next k
[b1].Resize(UBound(brr), 2) = brr
End Sub

laoau138

雄鹰2013 发表于 2016-10-14 19:16
Sub 雄鹰()
Dim arr
Set d = CreateObject("scripting.dictionary")

终于来论坛了

laoau138

雄鹰2013 发表于 2016-10-14 19:16
Sub 雄鹰()
Dim arr
Set d = CreateObject("scripting.dictionary")

http://www.excelpx.com/thread-427650-1-1.html

VBA计算等距离间隔循环相同数字

laoau138

雄鹰2013 发表于 2016-10-14 19:16
Sub 雄鹰()
Dim arr
Set d = CreateObject("scripting.dictionary")

http://www.excelpx.com/thread-427650-1-1.html

VBA计算等距离间隔循环相同数字