这么晚,早点睡吧!
举例里多余的数据先删除,如附件。你测试下吧- Sub 连续七个数出现的最大值_芐雨()
- Dim brr(1 To 1000000, 2), 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
- y = 1
- For j = 1 To col
- d.RemoveAll '每次转列:清空字典
- x = x + 1
- y = y + 7
- 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 = y 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
- y = y + 1
- brr(x, 1) = Right(brr(x - 1, 1), 7) '生成新的连续数
- brr(x, 2) = Right(brr(x - 1, 2), Len(brr(x - 1, 2)) - InStr(1, brr(x - 1, 2), ":")) '生成新的连续数地址
- 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
(12.63 KB, 下载次数: 3)
|