请教一个求最大月数问题

jiminyanyan

蓝桥玄霜 发表于 2016-7-7 11:33
请见代码。

感谢蓝老师。有个小问题。
201510
201511
201512
201601
201601
201602
这样的数据，中间出现两个201601，这个也算连续，我希望最大连续月份是5，而不是4.。

jiminyanyan

蓝桥玄霜 发表于 2016-7-7 11:33
请见代码。

1. Sub lqxs()
   
2.     Dim arr, i&, aa, j&, ks, n&, r%, arr1()
   
3.     Dim d, k, t
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Sheet1.Activate
   
6.     [i2:j500].Clear
   
7.     arr = [a1].CurrentRegion
   
8.     For i = 2 To UBound(arr)
   
9.         d(arr(i, 1)) = d(arr(i, 1)) & Mid(arr(i, 2), 5, 2) & ","
   
10.     Next
    
11.     k = d.keys
    
12.     t = d.items
    
13.     [i2].Resize(d.Count) = Application.Transpose(k)
    
14.     For i = 0 To UBound(k)
    
15.         t(i) = Left(t(i), Len(t(i)) - 1)
    
16.         n = 0
    
17.         r = 0
    
18.         If InStr(t(i), ",") Then
    
19.         aa = Split(t(i), ",")
    
20.         n = 1
    
21.         For j = 1 To UBound(aa)
    
22.             If Val(aa(j - 1)) <> 12 Then
    
23.                 If Val(aa(j)) - Val(aa(j - 1)) = 1 Then
    
24.                     n = n + 1
    
25.                 ElseIf Val(aa(j)) = Val(aa(j - 1)) Then
    
26.                 Else
    
27.                     r = r + 1
    
28.                     ReDim Preserve arr1(1 To r)
    
29.                     arr1(r) = n
    
30.                     n = 1
    
31.                 End If
    
32.             Else
    
33.                 If Val(aa(j)) = 1 Then
    
34.                     n = n + 1
    
35.                 ElseIf Val(aa(j)) = 12 Then
    
36.                 Else
    
37.                     r = r + 1
    
38.                     ReDim Preserve arr1(1 To r)
    
39.                     arr1(r) = n
    
40.                     n = 1
    
41.                 End If
    
42.              End If
    
43.             Next
    
44.             r = r + 1
    
45.             ReDim Preserve arr1(1 To r)
    
46.             arr1(r) = n
    
47.             Cells(i + 2, 10) = Application.Max(arr1)
    
48.         Else
    
49.             Cells(i + 2, 10) = 1
    
50.         End If
    
51.     Next
    
52.     [i1].CurrentRegion.Borders.LineStyle = 1
    
53.             
    
54. End Sub
    

复制代码

己搞定，谢谢各位。

小花鹿

另一个拆分工作薄的，今天练习了一下，抽空再练习一下这个。

小花鹿

Sub test()
Dim ar, d, i&, j&, dk, s, n&, m&, t, br
t = Timer
Set d = CreateObject("scripting.dictionary")
ar = [a1].CurrentRegion
For i = 2 To UBound(ar)
    d(ar(i, 1)) = d(ar(i, 1)) & "|" & i
Next i
dk = d.keys
ReDim br(1 To d.Count, 1 To 2)
For i = 0 To UBound(dk)
    br(i + 1, 1) = dk(i)
    s = Split(d(dk(i)), "|")
    For j = 1 To UBound(s) - 1
        If ar(s(j), 3) <> ar(s(j) + 1, 3) Then
            If ar(s(j), 3) - ar(s(j) + 1, 3) = -1 Or ar(s(j), 3) - ar(s(j) + 1, 3) = -89 Then
                n = n + 1
                If n > m Then m = n
            Else
                n = 0
            End If
        End If
    Next j
    br(i + 1, 2) = m + 1
    m = 0
Next i
[i9].Resize(d.Count, 2) = br
MsgBox Format(Timer - t, "0.0000")
End Sub