[已解决]智能判断代码的请求?

amulee

QUOTE:

以下是引用老鸭子在2010-5-31 15:46:00的发言：

在每组数据同样的位置同时都与最后的数据对等

2009139期的一平金，是该组数据的一平9行与该组数据的最后数据对等

2009153期的一平火，是该组数据的一平9行与该组数据的最后数据对等

2010007期的一平火，是该组数据的一平9行与该组数据的最后数据对等

2010032期的一平金，是该组数据的一平9行与该组数据的最后数据对等

 

 

 

2009140期的一平金，是该组数据的三平10行与该组数据的最后数据对等

2009154期的一平火，是该组数据的三平10行与该组数据的最后数据对等

2010008期的一平火，是该组数据的三平10行与该组数据的最后数据对等

2010033期的一平金，是该组数据的三平10行与该组数据的最后数据对等

 

 

 

2009141期的一平金，是该组数据的三平11行与该组数据的最后数据对等

2009155期的一平火，是该组数据的三平11行与该组数据的最后数据对等

2010009期的一平火，是该组数据的三平11行与该组数据的最后数据对等

2010034期的一平金，是该组数据的三平11行与该组数据的最后数据对等

并不是判断是否相等，而是要找出每组相对位置与该组最后数据都相等的这些数据。这样理解对不？

amulee

Sub 判断()
    Dim ArrYS, ArrJG1, ArrJG2, i&, j%, strTZ$, k&, Count&, ArrCount, CToTal
    ArrYS = Range("D2:Q" & Range("C65536").End(xlUp).Row)
    ReDim ArrJG1(1 To UBound(ArrYS), 1 To UBound(ArrYS, 2))
    ReDim ArrJG2(1 To UBound(ArrYS), 1 To UBound(ArrYS, 2))
    ReDim ArrCount(1 To 20, 1 To 14)
    For i = 1 To UBound(ArrYS)
        If Len(ArrYS(i, 1)) = 0 Then
            For k = i To UBound(ArrYS) - 1
                If Len(ArrYS(k + 1, 14)) = 0 Then
                    Count = 0
                    If k = UBound(ArrYS) - 1 Then
                        strTZ = ""
                        Exit For
                    End If
                    CToTal = CToTal + 1
                    strTZ = ArrYS(k, 14)
                    Exit For
                End If
            Next
        Else
            Count = Count + 1
            For j = 1 To 14
                If Len(strTZ) > 0 And ArrYS(i, j) = strTZ Then
                    ArrJG1(i, j) = strTZ
                    ArrCount(Count, j) = ArrCount(Count, j) + 1
                End If
            Next
        End If
    Next
    For i = 1 To 20
        For j = 1 To 14
            If ArrCount(i, j) = CToTal Then
                For k = 0 To CToTal - 1
                    Count = 21 * k + i + 1
                    ArrJG2(Count, j) = ArrJG1(Count, j)
                Next k
            End If
        Next j
    Next i
    Range("S2").Resize(UBound(ArrJG1), 14) = ArrJG1
    Range("AH2").Resize(UBound(ArrJG2), 14) = ArrJG2
End Sub

老鸭子

彻底的服了你，6楼和12楼是最佳的答案

谢谢！！！！！！！！！

如果每组数据的行数不是固定的，假如每组数据是10行，怎么办？

[此贴子已经被作者于2010-6-1 15:47:46编辑过]

amulee

Sub 判断()
    Dim ArrYS, ArrJG1, ArrJG2, i&, j%, strTZ$, k&, Count&, ArrCount, CToTal, ZCount
    ArrYS = Range("D2:Q" & Range("C65536").End(xlUp).Row)
    ReDim ArrJG1(1 To UBound(ArrYS), 1 To UBound(ArrYS, 2))
    ReDim ArrJG2(1 To UBound(ArrYS), 1 To UBound(ArrYS, 2))
   
    For i = 1 To UBound(ArrYS)
        If Len(ArrYS(i, 1)) = 0 Then
            For k = i To UBound(ArrYS) - 1
                If Len(ArrYS(k + 1, 14)) = 0 Then
                    Count = 0
                    If ZCount = 0 Then ZCount = k
                    If k = UBound(ArrYS) - 1 Then
                        strTZ = ""
                        Exit For
                    End If
                    CToTal = CToTal + 1
                    strTZ = ArrYS(k, 14)
                    Exit For
                End If
            Next
        Else
            If Not IsArray(ArrCount) Then
                ReDim ArrCount(1 To ZCount, 1 To 14)
            End If
            Count = Count + 1
            For j = 1 To 14
                If Len(strTZ) > 0 And ArrYS(i, j) = strTZ Then
                    ArrJG1(i, j) = strTZ
                    ArrCount(Count, j) = ArrCount(Count, j) + 1
                End If
            Next
        End If
    Next
    For i = 1 To ZCount
        For j = 1 To 14
            If ArrCount(i, j) = CToTal Then
                For k = 0 To CToTal - 1
                    Count = 21 * k + i + 1
                    ArrJG2(Count, j) = ArrJG1(Count, j)
                Next k
            End If
        Next j
    Next i
    Range("S2").Resize(UBound(ArrJG1), 14) = ArrJG1
    Range("AH2").Resize(UBound(ArrJG2), 14) = ArrJG2
End Sub

[此贴子已经被作者于2010-6-3 12:21:57编辑过]

白雪高山

学学

老鸭子

辛苦了，是我的表达能力有限，对不起！

当我的数据是每组10行时，运行不了，
每组20行可以运行

每组数据的行数同时变化的，数据表格行格式不是固定的

amulee

改过了，重新看看

老鸭子

我是用14楼的代码运行的，还是有问题 MHjXMjic.rar (35.34 KB, 下载次数: 0)

2010-6-3 12:40 上传

点击文件名下载附件
[已解决]智能判断代码的请求?

amulee

Sub 判断()
    Dim ArrYS, ArrJG1, ArrJG2, i&, j%, strTZ$, k&, Count&, ArrCount, CToTal, ZCount
    ArrYS = Range("D2:Q" & Range("C65536").End(xlUp).Row)
    ReDim ArrJG1(1 To UBound(ArrYS), 1 To UBound(ArrYS, 2))
    ReDim ArrJG2(1 To UBound(ArrYS), 1 To UBound(ArrYS, 2))
    For i = 1 To UBound(ArrYS)
        If Len(ArrYS(i, 1)) = 0 Then
            For k = i To UBound(ArrYS) - 1
                If Len(ArrYS(k + 1, 14)) = 0 Then
                    Count = 0
                    If ZCount = 0 Then ZCount = k
                    If k = UBound(ArrYS) - 1 Then
                        strTZ = ""
                        Exit For
                    End If
                    CToTal = CToTal + 1
                    strTZ = ArrYS(k, 14)
                    Exit For
                End If
            Next
        Else
            If Not IsArray(ArrCount) Then
                ReDim ArrCount(1 To ZCount, 1 To 14)
            End If
            Count = Count + 1
            For j = 1 To 14
                If Len(strTZ) > 0 And ArrYS(i, j) = strTZ Then
                    ArrJG1(i, j) = strTZ
                    ArrCount(Count, j) = ArrCount(Count, j) + 1
                End If
            Next
        End If
    Next
    For i = 1 To ZCount
        For j = 1 To 14
            If ArrCount(i, j) = CToTal Then
                For k = 0 To CToTal - 1
                    Count = (ZCount + 1) * k + i + 1
                    ArrJG2(Count, j) = ArrJG1(Count, j)
                Next k
            End If
        Next j
    Next i
    Range("S2").Resize(UBound(ArrJG1), 14) = ArrJG1
    Range("AH2").Resize(UBound(ArrJG2), 14) = ArrJG2
End Sub

老鸭子

呵呵，每组行数问题解决了，第二判断出现问题啦