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

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 - 1
                    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