|
|
代码如下。。。
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = "$Q$1" Then
arr = [h11:h140]
br = [n11:n140]
ReDim crr(1 To UBound(arr), 1 To 1)
ReDim drr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
If arr(i, 1) > 0 And br(i, 1) > 0 Then
drr(i, 1) = 1
ElseIf arr(i, 1) > 0 And br(i, 1) = 0 Then
drr(i, 1) = 2
Else
drr(i, 1) = 0
End If
crr(i, 1) = 0
s = s & CStr(drr(i, 1))
Next
ReDim brr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(drr)
If drr(i, 1) = 1 Then
x = InStr(i, s, "2")
y = InStr(i, s, "000")
If x < y And y > 0 Or x > 0 And y = 0 Then
n = n + 1
brr(n, 1) = i
brr(n, 2) = x - 1
i = x
' ElseIf x > 0 And y = 0 Then
' n = n + 1
' brr(n, 1) = i
' brr(n, 2) = x - 1
' i = x
Else
If y Then
n = n + 1
brr(n, 1) = i
brr(n, 2) = y - 1
i = y
Else
n = n + 1
brr(n, 1) = i
For k = UBound(drr) To i Step -1
If drr(k, 1) <> 0 Then Exit For
Next
brr(n, 2) = k
i = UBound(drr)
End If
End If
End If
Next
For i = 1 To n
x = 0
If brr(i, 2) - brr(i, 1) >= 3 Then
For k = brr(i, 1) To brr(i, 2)
x = x + IIf(drr(k, 1) > 0, 1, 0)
Next
If x > 3 Then
For k = brr(i, 1) To brr(i, 2)
crr(k, 1) = x
Next
End If
End If
Next
[q11].Resize(UBound(brr)) = crr
' [w11].Resize(UBound(brr), 2) = brr
Beep
End If
Application.EnableEvents = True
End Sub
|
评分
-
2
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-10-14 11:19
楼主
