求助vba高手如何用字典方式计算更快速

清风竹-

aails6543 发表于 2022-12-10 17:09
谢谢清风竹师傅，辛苦了。但好像 有漏统计了数据， 计算出来的数据有遗漏了首项值 0
如 第11位 +11 正确 ...

修改了一下。

wanao2008

我做出来后，数据底下是锯齿形的，对吗？

aails6543

wanao2008 发表于 2022-12-10 20:59
我做出来后，数据底下是锯齿形的，对吗？

是的，结果应是锯齿形的不相等行的底结果，谢谢老师回复。。 老师也是超厉害，记得上次把我工作中遇的实例详细讲述做成了课件。谢谢老师关注。

wanao2008

aails6543 发表于 2022-12-10 22:45
是的，结果应是锯齿形的不相等行的底结果，谢谢老师回复。。 老师也是超厉害，记得上次把我工作中遇的实 ...

主要是你的问题都是精品好实例

wanao2008

精品例子，继续提供“代码+视频讲解”的解决方案，
1、代码如下：

1. Sub byWanao()
   
2.     Dim i&, j&, k&, n&, arr, brr(), Dic As Object, jsNum&(30)
   
3.     Set Dic = CreateObject("Scripting.Dictionary")
   
4.     i = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
   
5.     arr = Sheet1.Range("C11:C" & i)
   
6.     For k = 1 To 18     '循环第1-18个数
   
7.         ReDim brr(1 To UBound(arr) \ 36, 30)
   
8.         Erase jsNum
   
9.         For i = k To UBound(arr) Step 36    '按36个数一组，循环取出相应位置的数
   
10.             Dic.RemoveAll
    
11.             For j = 1 To 18     '将后18位放置入字典，用于查重
    
12.                 Dic(arr(i - k + 18 + j, 1)) = ""
    
13.             Next
    
14.             For j = 0 To 30
    
15.                 jsNum(j) = jsNum(j) + 1
    
16.                 If Dic.exists(arr(i, 1) + j) Then
    
17.                     If jsNum(j) > 1 Then
    
18.                         If brr(jsNum(j) - 1, j) <> 0 Then jsNum(j) = jsNum(j) - 1
    
19.                     End If
    
20.                     brr(jsNum(j), j) = brr(jsNum(j), j) + 1
    
21.                 Else
    
22.                     brr(jsNum(j), j) = 0
    
23.                 End If
    
24.             Next
    
25.         Next
    
26.         For j = 0 To 30
    
27.             n = n + 1
    
28.             Sheet20.Cells(n, 2) = "第" & Format(k, "00") & "位加" & j & "连续累计最后" & brr(jsNum(j), j)
    
29.         Next
    
30.         Sheets(Right("0" & k, 2)).Range("H11").Resize(UBound(brr), 31) = brr
    
31.     Next
    
32. End Sub

复制代码

2、视频讲解地址：
既然是精品例子，肯定少了不录制视频，下面为B站的链接地址：
https://www.bilibili.com/video/BV1SR4y1r7C4/

aails6543

wanao2008 发表于 2022-12-11 15:24
精品例子，继续提供“代码+视频讲解”的解决方案，
1、代码如下：

哇塞，太厉害了，感动。一早看到老师给了代码视频解说。 我来好好学习消化一下。谢谢老师，

aails6543

非常感谢18楼，21楼，25楼三位师傅帮助，运行结果正确。辛苦了，感激！

fzxba

Sub test1() '练习 参与
  Dim vData, vResult(1 To 18), vTemp(), Dict As Object
  Dim vPos(), vNum(0 To 30) As Long, x As Integer, y As Long
  Dim i As Long, j As Long, p As Long, n As Long, s As String
  
  Application.ScreenUpdating = False
  Worksheets("Sheet1").Activate
  
  j = UBound(vResult)
  vData = Range("C11", Cells(Rows.Count, "C").End(xlUp)).Value
  ReDim vTemp(-Int(-UBound(vData) / j / 2), UBound(vNum))
  For n = LBound(vTemp, 2) To UBound(vTemp, 2)
    vTemp(0, n) = n
  Next
  ReDim vPos(1 To j)
  For x = LBound(vResult) To j
    vPos(x) = vNum
    vResult(x) = vTemp
  Next
  ReDim vTemp(n * j, 0)
  
  Set Dict = CreateObject("Scripting.Dictionary")
  For y = 1 To UBound(vData) Step j * 2
    Dict.RemoveAll
    For i = y + j To y + j * 2 - 1
      If Not Dict.Exists(vData(i, 1)) Then Dict.Add vData(i, 1), vbNullString
    Next
    For i = y To y + j - 1
      p = (i - 1) Mod (j * 2) + 1
      For n = LBound(vNum) To UBound(vNum)
        vPos(p)(n) = vPos(p)(n) + 1
        x = CInt(Dict.Exists(vData(i, 1) + n))
        If x Then
          If vPos(p)(n) > 1 Then
            If vResult(p)(vPos(p)(n) - 1, n) Then vPos(p)(n) = vPos(p)(n) - 1
          End If
        End If
        vResult(p)(vPos(p)(n), n) = vResult(p)(vPos(p)(n), n) - x
      Next
    Next
  Next
  
  y = 0
  For x = LBound(vResult) To j
    s = Format(x, "00")
    With Worksheets(s).Range("H10")
      .CurrentRegion.ClearContents
      .Resize(UBound(vResult(x)) + 1, UBound(vResult(x), 2) + 1) = vResult(x)
    End With
    s = "第" & s & "位加 [n] 连续累计最后是："
    For n = LBound(vNum) To UBound(vNum)
      vTemp(y, 0) = Replace(s, "[n]", n) & vResult(x)(vPos(x)(n), n)
      y = y + 1
    Next
  Next
  
  With Worksheets("结果表").Range("B1")
    .Resize(Rows.Count).ClearContents
    .Resize(y) = vTemp
  End With
  
  Set Dict = Nothing
  Application.ScreenUpdating = True
  Beep
End Sub

'评价侮辱了代码