[已解决]用VBA把字典改写数组计算多列最大连续

laoau138 · 发表于 2017-6-4 22:25

本帖最后由 laoau138 于 2017-6-7 21:28 编辑

Sub 用VBA数组计算多列最大连续次数2()
Dim d As Object, arA, arB, i%, x%, s$, s1$
Set d = CreateObject("Scripting.Dictionary")
arA = [f25:f29]
arB = [g1:i22]
For x = 1 To UBound(arB, 2)
      For i = 1 To UBound(arA)
         d(arA(i, 1)) = arA(i, 1) & 1
      Next
      For i = 2 To UBound(arB)
         s = Left(arB(i - 1, x), 1) & Mid(arB(i - 1, x), 3, 1)
         s1 = Left(arB(i, x), 1) & Mid(arB(i, x), 3, 1)
         If d.Exists(s1) And s = s1 Then d(s1) = s & Val(Mid(d(s1), 3, Len(d(s)))) + 1
      Next
      Cells(25, x + 6).Resize(d.Count, 1) = Application.Transpose(d.Items)
      d.RemoveAll
Next
End Sub

'用VBA把字典改写数组计算多列最大连续

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-6-7 13:46

你原来的代码是错的。

Sub aaa()
Dim arr, brr, i&, j&, k&, l&, n&, s$
arr = [g1].CurrentRegion
brr = [f25:f29]
ReDim Preserve brr(1 To 5, 1 To UBound(arr, 2) + 1)
For j = 1 To UBound(arr, 2)
For i = 1 To UBound(arr) - 1
For k = 1 To UBound(brr)
s = Left(arr(i, j), 1) & Mid(arr(i, j), 3, 1)
If brr(k, 1) = s Then
n = 1
For l = i + 1 To UBound(arr)
If s = Left(arr(l, j), 1) & Mid(arr(l, j), 3, 1) Then n = n + 1 Else Exit For
Next l
If brr(k, j + 1) < n Then brr(k, j + 1) = n
Exit For
End If
Next k
i = l - 1
Next i
Next j
For i = 1 To 5
For j = 2 To UBound(brr, 2)
brr(i, j) = brr(i, 1) & brr(i, j)
Next j
Next i
[f25].Resize(5, UBound(brr, 2)) = brr
End Sub

复制代码

跳转到最佳答案楼层

laoau138 · 发表于 2017-6-4 22:36

这一条如何做

大灰狼1976 · 发表于 2017-6-7 13:46

这个最佳答案由大灰狼1976 给出，感谢大灰狼1976 的回答。

单击隐藏图章

你原来的代码是错的。

Sub aaa()
Dim arr, brr, i&, j&, k&, l&, n&, s$
arr = [g1].CurrentRegion
brr = [f25:f29]
ReDim Preserve brr(1 To 5, 1 To UBound(arr, 2) + 1)
For j = 1 To UBound(arr, 2)
For i = 1 To UBound(arr) - 1
For k = 1 To UBound(brr)
s = Left(arr(i, j), 1) & Mid(arr(i, j), 3, 1)
If brr(k, 1) = s Then
n = 1
For l = i + 1 To UBound(arr)
If s = Left(arr(l, j), 1) & Mid(arr(l, j), 3, 1) Then n = n + 1 Else Exit For
Next l
If brr(k, j + 1) < n Then brr(k, j + 1) = n
Exit For
End If
Next k
i = l - 1
Next i
Next j
For i = 1 To 5
For j = 2 To UBound(brr, 2)
brr(i, j) = brr(i, 1) & brr(i, j)
Next j
Next i
[f25].Resize(5, UBound(brr, 2)) = brr
End Sub

复制代码

laoau138 · 发表于 2017-6-7 21:27

大灰狼1976 发表于 2017-6-7 13:46
你原来的代码是错的。

字典和数组2个答案都一样，请问错在哪里了

大灰狼1976 · 发表于 2017-6-8 09:34

你用我附件的数据做下测试便知

laoau138 · 发表于 2017-6-8 11:59

大灰狼1976 发表于 2017-6-8 09:34
你用我附件的数据做下测试便知

确实有错了，你竟然能发现

大灰狼1976 · 发表于 2017-6-8 12:31

laoau138 发表于 2017-6-8 11:59
确实有错了，你竟然能发现

因为我原来的思路竟然跟你的代码惊人的相似，在我意识到错了以后顺便看了一下你的代码，发现存在同样问题，最后进行了验证。

laoau138 · 发表于 2017-6-8 14:10

大灰狼1976 发表于 2017-6-8 12:31
因为我原来的思路竟然跟你的代码惊人的相似，在我意识到错了以后顺便看了一下你的代码，发现存在同样问题 ...

VBA比较A列唯一值掉改写不用goto语句

http://www.excelpx.com/thread-430934-1-1.html

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

[已解决]用VBA把字典改写数组计算多列最大连续

评分

评分

[已解决]用VBA把字典改写数组 计算多列最大连续

评分

评分

[已解决]用VBA把字典改写数组计算多列最大连续