'10w+数据不少，效率优先代码敲得多了点，，，
Option Explicit
Sub test()
Dim arr, i As Long, j As Long, k As Long, kk As Long
Dim t, m, s As String, p As Long, cnt As Long
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr, 1), 1 To 2)
Call qsort(arr, 2, UBound(arr, 1), 1, 3, 1)
For i = 2 To UBound(arr, 1)
If left(arr(i, 2), 1) = "B" Then
cnt = cnt + 1
brr(cnt, 1) = arr(i, 2): brr(cnt, 2) = i
End If
Next
If cnt = 0 Then MsgBox "!": Exit Sub
ReDim crr(1 To 10 ^ 6, 1 To 1) As String
Call qsort(brr, 1, cnt, 1, 2, 1)
p = 2
For i = 1 To cnt
If arr(brr(i, 2), 3) = 100 Then s = s & "," & arr(brr(i, 2), 1)
If brr(i, 1) <> brr(i + 1, 1) Then
For j = p To UBound(arr, 1)
If arr(j, 1) = brr(i, 1) Then
For k = j To UBound(arr, 1)
If arr(k, 1) <> brr(i, 1) Then p = k - 1: j = UBound(arr, 1): Exit For
t = Split(s, ",")
For kk = 1 To UBound(t)
m = m + 1
crr(m, 1) = t(kk) & "&" & arr(k, 2)
Next
Next
End If
Next
s = vbNullString
End If
Next
With [j3]
.Resize(Rows.Count - 2).ClearContents
If m > 0 Then .Resize(m) = crr
End With
End Sub
Function qsort(arr, first, last, left, right, key)
Dim i As Long, j As Long, k As Long, x As String, t
i = first: j = last: x = arr((first + last) / 2, key)
While i <= j
While StrComp(arr(i, key), x, vbTextCompare) = -1: i = i + 1: Wend
While StrComp(x, arr(j, key), vbTextCompare) = -1: j = j - 1: Wend
If i <= j Then
For k = left To right
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
i = i + 1: j = j - 1
End If
Wend
If first < j Then qsort arr, first, j, left, right, key
If i < last Then qsort arr, i, last, left, right, key
End Function |
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-12-9 20:32
楼主
发表于 2019-12-9 21:54
