|
楼主 |
发表于 2016-7-7 22:14
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub lqxs()
- Dim arr, i&, aa, j&, ks, n&, r%, arr1()
- Dim d, k, t
- Set d = CreateObject("scripting.dictionary")
- Sheet1.Activate
- [i2:j500].Clear
- arr = [a1].CurrentRegion
- For i = 2 To UBound(arr)
- d(arr(i, 1)) = d(arr(i, 1)) & Mid(arr(i, 2), 5, 2) & ","
- Next
- k = d.keys
- t = d.items
- [i2].Resize(d.Count) = Application.Transpose(k)
- For i = 0 To UBound(k)
- t(i) = Left(t(i), Len(t(i)) - 1)
- n = 0
- r = 0
- If InStr(t(i), ",") Then
- aa = Split(t(i), ",")
- n = 1
- For j = 1 To UBound(aa)
- If Val(aa(j - 1)) <> 12 Then
- If Val(aa(j)) - Val(aa(j - 1)) = 1 Then
- n = n + 1
- ElseIf Val(aa(j)) = Val(aa(j - 1)) Then
- Else
- r = r + 1
- ReDim Preserve arr1(1 To r)
- arr1(r) = n
- n = 1
- End If
- Else
- If Val(aa(j)) = 1 Then
- n = n + 1
- ElseIf Val(aa(j)) = 12 Then
- Else
- r = r + 1
- ReDim Preserve arr1(1 To r)
- arr1(r) = n
- n = 1
- End If
- End If
- Next
- r = r + 1
- ReDim Preserve arr1(1 To r)
- arr1(r) = n
- Cells(i + 2, 10) = Application.Max(arr1)
- Else
- Cells(i + 2, 10) = 1
- End If
- Next
- [i1].CurrentRegion.Borders.LineStyle = 1
-
- End Sub
复制代码
己搞定,谢谢各位。 |
|