'运行test这个过程即可
'看懂你的问题比写代码费劲的多,自己试下看看是不是这样的,,,
Option Explicit
Sub test()
Call fc1
Call fc2
End Sub
Function fc1()
Dim arr, i, j, cnt, n, p
arr = Range("a5:d" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
ReDim brr(1 To UBound(arr, 1), 1 To 1) As String
For i = 1 To UBound(arr, 1)
If Len(arr(i, 1)) Then
cnt = 0: ReDim t(2, 1) As Long
For j = i To UBound(arr, 1)
If Len(arr(j, 1)) Then
cnt = cnt + 1
t(Left(arr(j, 1), 1), 0) = t(Left(arr(j, 1), 1), 0) + 1
t(Right(arr(j, 1), 1), 1) = t(Right(arr(j, 1), 1), 1) + 1
If cnt = 3 Then
n = t(0, 0): p = 0
If n < t(1, 0) Then n = t(1, 0): p = 1
If n < t(2, 0) Then n = t(2, 0): p = 2
brr(j, 1) = IIf(n = 1, 3, p)
End If
If cnt = 3 Then
n = t(0, 1): p = 0
If n < t(1, 1) Then n = t(1, 1): p = 1
If n < t(2, 1) Then n = t(2, 1): p = 2
brr(j, 1) = brr(j, 1) & CStr(IIf(n = 1, 3, p))
i = j: Exit For
End If
End If
Next
End If
Next
[b5].Resize(UBound(brr, 1) - 1) = brr
End Function
Function fc2()
Dim arr, i, j, cnt, n, p
arr = Range("d5:d" & Cells(Rows.Count, "d").End(xlUp).Row + 1)
ReDim brr(1 To UBound(arr, 1), 1 To 1) As String
For i = 1 To UBound(arr, 1)
If Len(arr(i, 1)) Then
cnt = 0: ReDim t(2) As Long
For j = i To UBound(arr, 1)
If Len(arr(j, 1)) Then
cnt = cnt + 1
t(arr(j, 1)) = t(arr(j, 1)) + 1
If cnt = 3 Then
n = t(0): p = 0
If n < t(1) Then n = t(1): p = 1
If n < t(2) Then n = t(2): p = 2
brr(j, 1) = IIf(n = 1, 3, p)
i = j: Exit For
End If
End If
Next
End If
Next
[e5].Resize(UBound(brr, 1) - 1) = brr
End Function |