楼主
芐雨 |
例子来自EP网友的一个问题。
求：每个单元格0-9之间取值，有7个数字连续出现的最大次数。
如：A1：A12分别是 110345677899 ，其实共有三组7个连续数（1034567，0345678，3456789）
1034567：9次
0345678：8次
3456789：9次
取第一组最大值
代码如下：
- Sub 连续七个数出现的最大值_芐雨()
- Dim brr(), crr(1 To 10000, 1 To 11)
- Dim Rng As Range, arr
- Application.ScreenUpdating = False
- Set d = CreateObject("scripting.dictionary")
- Set Rng = Sheets("举例").Range("A1").CurrentRegion '范围
- Sheets("芐雨").Range("A2").Resize(Rows.Count - 1, 11).Clear '清除数据
- col = Rng(Rng.Count).Column '列数
- arr = Rng
- For j = 1 To col
- ReDim brr(1 To UBound(arr), 1 To 2)
- d.RemoveAll
- x = 1
- jmax = 0
- For i = 1 To UBound(arr)
- arr(i, j) = arr(i, j) & "" '转成字符
- If Not d.exists(arr(i, j)) Or i = UBound(arr) Then '字典不存在或最后一行时运行
- k = k + 1 '记录字典数
- d(arr(i, j)) = "" '添加字典
- brr(x, 1) = brr(x, 1) & arr(i, j) '记录出现的数
- If brr(x, 2) <> "" Then
- brr(x, 2) = brr(x, 2) & ":" & Cells(i, j).Address '记录地址
- Else
- brr(x, 2) = Cells(i, j).Address '记录地址
- End If
- If k = 8 Then
- If i < UBound(arr) Then '不是最后一行时
- d.Remove (Left(brr(x, 1), 1)) '删除第一个数的字典
- L = InStrRev(brr(x, 2), "$") '最后一个$的位置
- brr(x, 2) = Left(brr(x, 2), L) & Right(brr(x, 2), Len(brr(x, 2)) - L) - 1 '最后一个地址上移一格
- End If
- imax = Range(brr(x, 2)).Count '求出连续出现的数
- If imax >= jmax Then '比较是否最大值
- jmax = imax
- crr(j, 2) = "'" & Left(brr(x, 1), 7) '转成文本数值，记录出现什么数
- crr(j, 4) = Range(brr(x, 2)).Item(1).Address(0, 0) '返回区域内的第一个地址
- crr(j, 6) = Range(brr(x, 2)).Item(imax).Address(0, 0) '返回区域内的最后个地址
- crr(j, 8) = jmax '连续出现的次数
- End If
- x = x + 1 '记录
-
- d.RemoveAll
- k = 0
- If i = UBound(arr) Then Exit For
- i = x
- End If
- End If
- Next
- Next
- For j = 1 To col
- crr(j, 1) = "第" & j & "列最大结果"
- crr(j, 3) = "从"
- crr(j, 5) = "到"
- crr(j, 7) = "次"
- crr(j, 9) = "出现"
- crr(j, 11) = "没有出现"
- crr(j, 10) = "1234567890"
- For i = 2 To 8 '找出没有出现的数
- crr(j, 10) = Replace(crr(j, 10), Val(Mid(crr(j, 2), i, 1)), "")
- Next
- Next
- Sheets("芐雨").Range("A2").Resize(col, 11) = crr
- Application.ScreenUpdating = True
- End Sub
附件：
 连续七个数出现的最大值_芐雨.rar
|