Я придумал этот. Он создает два массива, один из которых содержит две ключевые имена в данной ячейке в столбце B, а другой - с количеством слов в каждом элементе массива arr1. Затем он отправляет два массива в Sort2 Sub, который был написан участником Gary's Student и может быть найден here. Предполагается, что имена множественного выбора находятся в столбце «B» и что «Jon» и «Smith» жестко закодированы, но могут быть сделаны из другого столбца с небольшим изменением кода.
Колонка B содержит: Джон Смит Смит Джон Младший Смит Джон
Sub create2arr()
Dim myArr() As Variant, name1 As String, name2 As String, firstMarker As Boolean, myArrayCounter As Long, myArray2Counter As Long
Dim splitArr() As String, wordCountArr() As Variant
name1 = "Jon"
name2 = "Smith"
ReDim myArr(1 To 1)
ReDim myArr2(1 To 1)
ReDim wordCountArr(1 To 1)
myArrayCounter = 1
myArray2Counter = 1
For I = 1 To 3
splitArr = Split(Sheet6.Range("B" & I))
For J = LBound(splitArr) To UBound(splitArr)
If UCase(splitArr(J)) = UCase(name1) Or UCase(splitArr(J)) = UCase(name2) Then
If firstMarker = True Then
myArr(myArrayCounter) = Sheet6.Range("B" & I)
wordCountArr(myArrayCounter) = UBound(splitArr) + 1
myArrayCounter = myArrayCounter + 1
ReDim Preserve myArr(1 To myArrayCounter)
ReDim Preserve wordCountArr(1 To myArrayCounter)
firstMarker = False
Else
firstMarker = True
End If
End If
Next J
Next I
For I = 1 To UBound(myArr)
Debug.Print myArr(I)
Next I
Call sort2(wordCountArr, myArr)
For I = 1 To UBound(myArr)
Debug.Print myArr(I)
Next I
End Sub
Sub sort2(key() As Variant, other() As Variant)
Dim I As Long, J As Long, Low As Long
Dim Hi As Long, Temp As Variant
Low = LBound(key)
Hi = UBound(key)
J = (Hi - Low + 1) \ 2
Do While J > 0
For I = Low To Hi - J
If key(I) > key(I + J) Then
Temp = key(I)
key(I) = key(I + J)
key(I + J) = Temp
Temp = other(I)
other(I) = other(I + J)
other(I + J) = Temp
End If
Next I
For I = Hi - J To Low Step -1
If key(I) > key(I + J) Then
Temp = key(I)
key(I) = key(I + J)
key(I + J) = Temp
Temp = other(I)
other(I) = other(I + J)
other(I + J) = Temp
End If
Next I
J = J \ 2
Loop
End Sub
Вы хотите «Нечеткий уточняющий запрос» добавить, есть много. У Microsoft есть один. –
Очень полезно знать, спасибо @ScottCraner –