求个代码

quqiyuan

wenping998 发表于 2024-11-6 09:38
这个代码 接近完美了  就是  L列缺少最后一个数字2  也就是G列的 最后的两个重 然后R列也要统计上

改好了，判断最后是有点麻烦。你测试一下咯

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    For i = 3 To 5
        r = sht.Cells(Rows.Count, i).End(3).Row
        x = Application.Max(r, x)
    Next
    arr = sht.Range("c1:e" & x)
    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) And j <> UBound(drr) Then
                n = n + 1
            ElseIf drr(j, 1) <> drr(i, 1) And j <> UBound(drr) Then    'Or j = UBound(drr)
                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
            ElseIf drr(j, 1) = drr(i, 1) And j = UBound(drr) Then
                If drr(i, 1) = "重" Then
                    m = m + 1
                    i = j - 1: crr(m, 1) = n + 1: Exit For
                ElseIf drr(i, 1) = "邻" Then
                    m1 = m1 + 1
                    i = j - 1: crr(m1, 2) = n + 1: Exit For
                Else
                    m2 = m2 + 1
                    i = j - 1: crr(m2, 3) = n + 1: Exit For
                End If
            ElseIf drr(j, 1) <> drr(i, 1) And j = UBound(drr) Then
                If drr(i, 1) = "重" Then
                    m = m + 1
                    crr(m, 1) = 1
                ElseIf drr(i, 1) = "邻" Then
                    m1 = m1 + 1
                    crr(m1, 2) = 1
                Else
                    m2 = m2 + 1
                    crr(m2, 3) = 1
                End If
                If drr(j, 1) = "重" Then
                    m = m + 1
                    i = j - 1: crr(m, 1) = 1: Exit For
                ElseIf drr(j, 1) = "邻" Then
                    m1 = m1 + 1
                    i = j - 1: crr(m1, 2) = 1: Exit For
                Else
                    m2 = m2 + 1
                    i = j - 1: crr(m2, 3) = 1: 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-6 13:16
代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet

这下就闭环了  完美

wenping998

quqiyuan 发表于 2024-11-6 13:16
代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet

大哥 又加了个表 跟之前的类似 计算范围是0-6  B1是辅助行   又得麻烦你弄个代码 辛苦你了

quqiyuan

wenping998 发表于 2024-11-8 09:57
大哥 又加了个表 跟之前的类似 计算范围是0-6  B1是辅助行   又得麻烦你弄个代码 辛苦你了

仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")                              'wb.Sheets("sheet2")
    For i = 3 To 5
        r = sht.Cells(Rows.Count, i).End(3).Row
        x = Application.Max(r, x)
    Next
    arr = sht.Range("c1:i" & x)
    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 Else
                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) And j <> UBound(drr) Then
                n = n + 1
            ElseIf drr(j, 1) <> drr(i, 1) And j <> UBound(drr) Then    'Or j = UBound(drr)
                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
            ElseIf drr(j, 1) = drr(i, 1) And j = UBound(drr) Then
                If drr(i, 1) = "重" Then
                    m = m + 1
                    i = j - 1: crr(m, 1) = n + 1: Exit For
                ElseIf drr(i, 1) = "邻" Then
                    m1 = m1 + 1
                    i = j - 1: crr(m1, 2) = n + 1: Exit For
                Else
                    m2 = m2 + 1
                    i = j - 1: crr(m2, 3) = n + 1: Exit For
                End If
            ElseIf drr(j, 1) <> drr(i, 1) And j = UBound(drr) Then
                If drr(i, 1) = "重" Then
                    m = m + 1
                    crr(m, 1) = 1
                ElseIf drr(i, 1) = "邻" Then
                    m1 = m1 + 1
                    crr(m1, 2) = 1
                Else
                    m2 = m2 + 1
                    crr(m2, 3) = 1
                End If
                If drr(j, 1) = "重" Then
                    m = m + 1
                    i = j - 1: crr(m, 1) = 1: Exit For
                ElseIf drr(j, 1) = "邻" Then
                    m1 = m1 + 1
                    i = j - 1: crr(m1, 2) = 1: Exit For
                Else
                    m2 = m2 + 1
                    i = j - 1: crr(m2, 3) = 1: Exit For
                End If
            End If
        Next
    Next
    x = Application.Max(m, m1, m2)
    ar = sht.[k1:m1]
    br = sht.[u2:u20]
    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
    With sht
        .[k2:m360,p2:r360,v2:x360].ClearContents
        .[k2].Resize(UBound(brr), 3) = brr
        .[p2].Resize(x, 3) = crr
        .[v2].Resize(UBound(cr), 3) = cr
    End With
    Set d = Nothing
    Beep
End Sub
   

wenping998

quqiyuan 发表于 2024-11-9 10:37
仅供参考。。。

奇怪  最后358 359 360 行没有计算数据 怎么回事呢

quqiyuan

wenping998 发表于 2024-11-9 12:29
奇怪  最后358 359 360 行没有计算数据 怎么回事呢

quqiyuan

代码如下。。。。
Sub test()
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")                              'wb.Sheets("sheet2")
    For i = 3 To 9
        r = sht.Cells(Rows.Count, i).End(3).Row
        x = Application.Max(r, x)
    Next
    arr = sht.Range("c1:i" & x)
    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 Else
                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) And j <> UBound(drr) Then
                n = n + 1
            ElseIf drr(j, 1) <> drr(i, 1) And j <> UBound(drr) Then    'Or j = UBound(drr)
                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
            ElseIf drr(j, 1) = drr(i, 1) And j = UBound(drr) Then
                If drr(i, 1) = "重" Then
                    m = m + 1
                    i = j - 1: crr(m, 1) = n + 1: Exit For
                ElseIf drr(i, 1) = "邻" Then
                    m1 = m1 + 1
                    i = j - 1: crr(m1, 2) = n + 1: Exit For
                Else
                    m2 = m2 + 1
                    i = j - 1: crr(m2, 3) = n + 1: Exit For
                End If
            ElseIf drr(j, 1) <> drr(i, 1) And j = UBound(drr) Then
                If drr(i, 1) = "重" Then
                    m = m + 1
                    crr(m, 1) = 1
                ElseIf drr(i, 1) = "邻" Then
                    m1 = m1 + 1
                    crr(m1, 2) = 1
                Else
                    m2 = m2 + 1
                    crr(m2, 3) = 1
                End If
                If drr(j, 1) = "重" Then
                    m = m + 1
                    i = j - 1: crr(m, 1) = 1: Exit For
                ElseIf drr(j, 1) = "邻" Then
                    m1 = m1 + 1
                    i = j - 1: crr(m1, 2) = 1: Exit For
                Else
                    m2 = m2 + 1
                    i = j - 1: crr(m2, 3) = 1: Exit For
                End If
            End If
        Next
    Next
    x = Application.Max(m, m1, m2)
    ar = sht.[k1:m1]
    br = sht.[u2:u20]
    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
    With sht
        .[k2:m360,p2:r360,v2:x360].ClearContents
        .[k2].Resize(UBound(brr), 3) = brr
        .[p2].Resize(x, 3) = crr
        .[v2].Resize(UBound(cr), 3) = cr
    End With
    Set d = Nothing
    Beep
End Sub
   

wenping998

quqiyuan 发表于 2024-11-9 12:39

哥 这个代码给加个循环  至少有4个sheet 要用 然后 CDEFGHI区域要是有7000行  改怎么改代码