Option Explicit
Sub test()
Dim arr, i, j, k, m, p
arr = Sheets("实际运行结果").[a1].CurrentRegion
ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2)) As String
For i = 1 To UBound(arr, 1)
If Len(arr(i, 2)) Then
For j = 1 To UBound(arr, 1)
p = InStr(arr(j, 1), arr(i, 2))
If p > 15 Then
If Mid(arr(j, 1), p - 1, 1) = """" Then
m = m + 1
brr(m, 1) = arr(j, 1): brr(m, 2) = arr(i, 2):: brr(m, 3) = arr(i, 3)
Exit For
End If
End If
Next
End If
Next
With Sheets("想要的结果").[e1]
.Resize(Rows.Count, UBound(brr, 2)).ClearContents
If m > 0 Then .Resize(m, UBound(brr, 2)) = brr
End With
End Sub |