求个代码

quqiyuan · 发表于 2024-11-6 13:15

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

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

quqiyuan · 发表于 2024-11-6 13:16

代码如下。。。
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 · 发表于 2024-11-6 17:32

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

这下就闭环了完美

wenping998 · 发表于 2024-11-8 09:57

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

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

quqiyuan · 发表于 2024-11-9 10:37

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

仅供参考。。。

quqiyuan · 发表于 2024-11-9 10:37

代码如下。。。
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 · 发表于 2024-11-9 12:29

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

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

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

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

quqiyuan · 发表于 2024-11-9 12:40

代码如下。。。。
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 · 发表于 2024-11-13 17:10

本帖最后由 wenping998 于 2024-11-14 09:22 编辑

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

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

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

[求助] 求个代码

评分

评分

评分

评分

评分

评分