[已解决]求数组元素连续个数最大值和最大值个数的代码

FF7 · 发表于 2012-2-13 23:23

本帖最后由 FF7 于 2012-2-13 23:27 编辑

上清宫主发表于 2012-2-13 21:55
这个帖子有意思，学习群子等各位大大的了！
37、39楼为什么非要For i = 0 To UBound(Arr) - 1？先将第0个处 ...

呵呵，48楼的代码纯粹是想把啰嗦的条件语句全部去掉。不过的确如上清宫主所言，还要考虑到效率！那就增加一些条件语句。似乎代码这样更简化咯！！

Sub xx()
Dim t As Integer, n As Integer, x As Integer, y As Integer, strA As String, a(0 To 9, 0 To 1), Arr
Arr = Array(0, 1, 1, 1, 0, 0, 2, 2, 1, 3, 3, 0, 0, 1, 1, 1, 2, 3, 0, 2)
t = 999
For i = 0 To UBound(Arr)
If Arr(i) <> t Then
t = Arr(i)
n = 1
If y < Arr(i) Then y = Arr(i)
Else
n = n + 1
End If
If n > a(t, 0) Then
a(t, 0) = n
a(t, 1) = 1
ElseIf n = a(t, 0) Then
a(t, 1) = a(t, 1) + 1
End If
Next
For m = 0 To y
strA = strA & m & "最大连续" & a(m, 0) & "次，这种连续总共出现" & a(m, 1) & "次。" & Chr(10)
Next
MsgBox strA
End Sub

复制代码

代码二：对任意字符或字符串统计最大连续及其次数！
宫主再帮忙参谋参谋！！

Sub yy()
Dim dc As Object
Set dc = CreateObject("Scripting.dictionary")
Arr = Array(0, 1, 1, "A", "A", 1, 0, 0, 2, 2, "中", "中", "国", 1, 3, 3, 0, 0, 1, 1, 1, 2, 3, 0, 2, "A", "A", "B", "B", "C", "A", "A")
Dim i As Integer, n As Long, x As Integer, a()
strA = ""
For i = 0 To UBound(Arr)
If Arr(i) <> strA Then
If Not dc.exists(Arr(i)) Then
ReDim Preserve a(0 To 1, 0 To x)
dc(Arr(i)) = x
x = x + 1
End If
strA = Arr(i)
n = 1
Else
n = n + 1
End If
If n > a(0, dc(strA)) Then
a(0, dc(strA)) = n
a(1, dc(strA)) = 1
ElseIf n = a(0, dc(strA)) Then
a(1, dc(strA)) = a(1, dc(strA)) + 1
End If
Next
b = dc.keys
strA = "所有元素最大连续及其出现次数统计："
For i = 0 To UBound(b)
strA = strA & Chr(10) & b(i) & "--最大连续" & a(0, dc(b(i))) & "次，其出现的次数为" & a(1, dc(b(i))) & "次"
Next
MsgBox strA
End Sub

复制代码

上清宫主 · 发表于 2012-2-13 23:38

FF7 发表于 2012-2-13 23:23
呵呵，48楼的代码纯粹是想把啰嗦的条件语句全部去掉。不过的确如上清宫主所言，还要考虑到效率！那就增加 ...

不敢！
来学习的
只是感觉n向数组a赋值的这个if块似乎放到上一个if里面去好点，不然有用没用都在向a中赋值，不过这一来，就回到群子的路子上去了

FF7 · 发表于 2012-2-13 23:55

本帖最后由 FF7 于 2012-2-13 23:56 编辑

上清宫主发表于 2012-2-13 23:38
不敢！
来学习的
只是感觉n向数组a赋值的这个if块似乎放到上一个if里面去好点，不然有用没用都在向a中赋 ...

错了！
如果将if n > a... then 放到上面的if 语句中，那么在
If ... Then
(1)
Else
(2)
end if
这段代码的(1),(2)位置，均需要赋值语句。
因为有一种情况比如 1,0,2,3
那么即便当arr(i)<>t的时候，0,1,2,3出现的次数均为1，最大连续为1，次数为1。

if n这个条件，可以不论连续出现几次，均取最大连续进行赋值。即便是第一次出现的新值，也可以赋初值。既然可以用一个统一语句完成赋初值以及取最大值的过程，那么就不必要在if ... then语句块中重复了！

上清宫主 · 发表于 2012-2-14 00:25

各人思路不同观点不同。在看群子的

haiyang81 · 发表于 2012-2-17 20:04

有没有高手帮忙把37#香川群子的代码改成自定义函数。
谢谢啦

香川群子 · 发表于 2012-2-17 21:23

本帖最后由香川群子于 2012-2-17 21:26 编辑

上清宫主发表于 2012-2-13 21:55
这个帖子有意思，学习群子等各位大大的了！
37、39楼为什么非要For i = 0 To UBound(Arr) - 1？先将第0个处 ...

37、39楼循环，从0开始到 ubound（arr）-1结束，当时是思路限制，不得已的做法。

你也可以试试，即使0先处理，也是没法简单做好。

不过，看了你的帖子提出的问题，我决定重新思考一下。
最后，想到了比较完美的解决方案，如今的代码，更为简单了。

当然效率也更高了。

Sub ArrCount()
Dim i%, arr(), brr(), t%, l%, StrT$
arr = Array(0, 1, 1, 1, 0, 0, 2, 2, 1, 3, 3, 0, 0, 1, 1, 1, 2, 3, 0, 2, 5)
ReDim Preserve arr(UBound(arr) + 1) '本帖亮点。对原始数据做增加1行空白值的预处理。
ReDim brr(9, 1) '假定目前处理对象为数字0-9
t = arr(0): l = 1 '处理第一个元素。使用t记录当前值，l记录当前连续长度，减少了数组占用内存。
For i = 1 To UBound(arr)
If arr(i) = t Then '检查值和上一个值相同时
l = l + 1 '连续长度+1
Else '检查值和上一个值不同时
If l > brr(t, 0) Then '如果当前长度大于记录长度
brr(t, 0) = l '更新长度值
brr(t, 1) = 1 '更新次数归零=1
ElseIf brr(t, 0) = l Then '如果当前长度等于记录长度
brr(t, 1) = brr(t, 1) + 1 '则次数+1
End If
t = arr(i): l = 1 '然后更新当前检查值、连续长度归零=1
End If
Next
'到这里完成所有统计，下面是整理输出结果。
[b1].Resize(10, 2) = brr '直接输出未加整理的结果
For i = 0 To 9 '整理输出有效结果
If brr(i, 0) > 0 Then StrT = StrT & vbCr & i & " Continue Max Count " & brr(i, 0) & ", Frequency " & brr(i, 1) & " times"
Next i
MsgBox "Continue Max Count Detail: " & StrT
End Sub

复制代码

最大的关键，在于把原始数组arr做了处理，在数组末尾增加了一个空白记录，
即，原始数组有n个值时，处理以后变成了n+1个值，
以便代码运行到最后，能够正确处理第n个值，而忽略第n+1个值。

最后，为了保证增加的记录不产生干扰，即希望不和前面0-9的值相同，
决定只增加空白就够了。

代码完成以后，效果真是好。

今后，我自己也多了一种方法。呵呵。

香川群子 · 发表于 2012-2-17 21:47

本帖最后由香川群子于 2012-2-17 22:04 编辑

56楼代码ArrCount，比48楼xx-1代码快。大约是3：5的样子，即快了大约40%

56楼代码ArrCount，比51楼xx-2代码快。大约是3.4：5的样子，即快了大约30%

37楼代码ArrayCount，速度最慢。
48楼代码，介于37楼和51楼之间。即，比37楼快10%，比51楼慢大约10%。

备注，速度比较只比较计算部分，结果不输出。

速度比较方法为统计连续运行10万次耗费的时间。

Sub speedcompare()
Dim m%, i&
m = 5

tms = Timer
For i = 1 To 10 ^ m
      ArrCount
Next
MsgBox Format(Timer - tms, "0.000s") '平均耗时 1.5秒

tms = Timer
For i = 1 To 10 ^ m
      ArrayCount
Next
MsgBox Format(Timer - tms, "0.000s") '平均耗时 2.78秒

tms = Timer
For i = 1 To 10 ^ m
      xx1
Next
MsgBox Format(Timer - tms, "0.000s") '平均耗时 2.5秒

tms = Timer
For i = 1 To 10 ^ m
      xx2
Next
MsgBox Format(Timer - tms, "0.000s") '平均耗时 2.2秒

End Sub

因电脑环境不同，统计时间会有差异。

爱疯 · 发表于 2012-2-18 20:59

香川群子发表于 2012-2-10 11:03
你这个代码有致命缺陷：

A = Array(0, 1, 1, 1, 0, 0, 2, 2, 1, 3, 3, 0, 0, 1, 1, 1, 2, 3, 0, 2, 5) ...

谢谢群子老师的指点

改正统计0次或1次的情况。

Sub test()
Dim A, m%, n%, i%, j%, x$, y$, arr
A = Array(0, 1, 1, 1, 0, 0, 2, 2, 1, 3, 3, 0, 0, 1, 1, 1, 2, 3, 0, 2, 5)
m = Application.Min(A): n = Application.Max(A)
ReDim arr(1 To n - m + 1, 1 To 3)
x = Join(A, "")
For i = m To n
j = j + 1
y = pd(x, i)
arr(j, 1) = i
arr(j, 2) = Split(y, ",")(0)
arr(j, 3) = Split(y, ",")(1)
Next i
Stop
End Sub
Function pd(x, i) As String '判断
Dim regex As Object, matchs As Object, match As Object
Dim k As Integer, s As Integer
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.Pattern = i & "+"
Set matchs = .Execute(x)
For Each match In matchs
If match.Length = k Then '表示最大连续k次
s = s + 1 's表示最大连续k次的计数
ElseIf match.Length > k Then
k = match.Length
s = 1 '由于k更新了，所以s也要更新
End If
Next
End With
pd = k & "," & s
End Function

复制代码

紫晨 · 发表于 2013-3-16 14:40

高手啊——可惜咱看不懂

		自动登录	找回密码
密码			注册