求个代码

quqiyuan

代码如下，，，
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    arr = sht.[c1:e360]
    ReDim brr(1 To UBound(arr) - 1, 1 To 3)
    ReDim drr(1 To UBound(arr) - 1, 1 To 1)
    For i = 2 To UBound(arr)
        x = Application.Sum(Application.Index(arr, i)) _
                - Application.Sum(Application.Index(arr, i - 1))
        Select Case Abs(x)
            Case 0
                brr(i - 1, 1) = "重"
                drr(i - 1, 1) = "重"
            Case 1
                brr(i - 1, 2) = "邻"
                drr(i - 1, 1) = "邻"
            Case 2
                brr(i - 1, 3) = "孤"
                drr(i - 1, 1) = "孤"
        End Select
    Next
    ReDim crr(1 To UBound(drr), 1 To 3)
    For i = 1 To UBound(drr) - 1
        n = 1
        For j = i + 1 To UBound(drr)
            If drr(j, 1) = drr(i, 1) Then
                n = n + 1
            Else
                If drr(i, 1) = "重" Then
                    m = m + 1
                    i = j - 1: crr(m, 1) = n: Exit For
                ElseIf drr(i, 1) = "邻" Then
                    m1 = m1 + 1
                    i = j - 1: crr(m1, 2) = n: Exit For
                Else
                    m2 = m2 + 1
                    i = j - 1: crr(m2, 3) = n: Exit For
                End If
            End If
        Next
    Next
    x = Application.Max(m, m1, m2)
    ar = [r1:t1]
    br = [q2:q20]
    n = 0
    ReDim cr(1 To UBound(br), 1 To 3)
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(br)
        n = n + 1
        For j = 1 To UBound(ar, 2)
            s = br(i, 1) & ar(1, j)
            d(s) = n
        Next
    Next
    For j = 1 To UBound(ar, 2)
        For i = 1 To x
            If crr(i, j) <> Empty Then
                s = crr(i, j) & ar(1, j)
                cr(d(s), j) = cr(d(s), j) + 1
            End If
        Next
    Next
    [g2:i360,l2:n360,r2:t360].ClearContents
    [g2].Resize(UBound(brr), 3) = brr
    [l2].Resize(x, 3) = crr
    [r2].Resize(UBound(cr), 3) = cr
    Set d = Nothing
    Beep
End Sub

wenping998

quqiyuan 发表于 2024-11-5 17:12
代码如下，，，
Sub test()
    Dim wb As Workbook, sht As Worksheet

哥 你的代码很厉害 可以改进下吗 就是在 CDE列有数字就计算 CDE列没有数字就不用计算

quqiyuan

wenping998 发表于 2024-11-5 19:05
哥 你的代码很厉害 可以改进下吗 就是在 CDE列有数字就计算 CDE列没有数字就不用计算

如果有些没有数字，那么前后的重啊邻啊孤啊怎么算呢，上下没法比较

wenping998

quqiyuan 发表于 2024-11-5 19:39
如果有些没有数字，那么前后的重啊邻啊孤啊怎么算呢，上下没法比较

比如 360没有数字 360行就可以不用算了  359行里的CDE列对应358行计算重邻孤

quqiyuan

wenping998 发表于 2024-11-5 19:57
比如 360没有数字 360行就可以不用算了  359行里的CDE列对应358行计算重邻孤

如果359行没有，358行360行有数据怎么算，还是说哪一行开始没有数据，后面的都没有了，例如350行没有了，后面的都没有了？

wenping998

quqiyuan 发表于 2024-11-5 20:07
如果359行没有，358行360行有数据怎么算，还是说哪一行开始没有数据，后面的都没有了，例如350行没有了， ...

对，数据是连续的，中间不会断。比如360行没有，那之后就没有了.359行之前都会有。要不你留个微信，我们以后方便沟通。

wenping998

quqiyuan 发表于 2024-11-5 20:07
如果359行没有，358行360行有数据怎么算，还是说哪一行开始没有数据，后面的都没有了，例如350行没有了， ...

对，数据是连续的，中间不会断。比如360行没有，那之后就没有了.359行之前都会有。

wenping998

quqiyuan 发表于 2024-11-5 20:07
如果359行没有，358行360行有数据怎么算，还是说哪一行开始没有数据，后面的都没有了，例如350行没有了， ...

为什么有这个想法 就是你把我的表格数据 CDE列删除351行之后的数据 再点运行代码 就可以发现问题 像删除了数据后 对应的重邻孤不应该还有对应的数据 所以后面关联的运算会出现错误

quqiyuan

wenping998 发表于 2024-11-5 21:34
为什么有这个想法 就是你把我的表格数据 CDE列删除351行之后的数据 再点运行代码 就可以发现问题 像删除 ...

wenping998

quqiyuan 发表于 2024-11-5 21:54

这个代码 接近完美了  就是  L列缺少最后一个数字2  也就是G列的 最后的两个重 然后R列也要统计上