Блог

Я пытаюсь создать формулу, которая показывает все совпадающие поля, но в дополнение включает «связанные ячейки». Что-то вроде этого —

Пользователь вводит «Брэд», и в окне результата должно отображаться «Брэд, Адам, Чарли, Дэвид», потому что Брэд связан с Адамом, а Адам связан с Чарли и Дэвидом.

 A     B
Adam|Brad
Adam|Charlie
Adam|David
Evan|Fred
  

Формула:

 {IFERROR(IFERROR(INDEX(Column B,SMALL(IF(Column A=InputCriteria,ROW(Column A)-1),ROW(1:1))),INDEX(Column A,SMALL(IF(Column B=InputCriteria,ROW(Column B)-1),ROW(1:1)))),"")}
  

Меня зовут Брэд, поэтому я ничего не мог с собой поделать, мне пришлось попробовать решение. 🙂

Добавьте следующий код в новый модуль в вашем редакторе VBA…

 Public Function GetAssociatedNames(ByVal strName As String, ByVal rngCells As Range) As String
    Dim lngRow As Long, lngCol As Long, lngBlanks As Long, objNames As Scripting.Dictionary
    Dim strName1 As String, strName2 As String, i As Long, strNameToAdd As String, x As Long
    Dim lngStart As Long, lngCount As Long, lngForCount As Long

    strName = Trim(strName)

    Set objNames = New Scripting.Dictionary
    objNames.Add strName, strName

    With rngCells
        lngStart = 0

        Do While True
            lngForCount = objNames.Count - 1

            If lngStart > lngForCount Then Exit Do

            For x = lngStart To lngForCount
                strName = objNames.Keys(x)

                lngCount = objNames.Count

                For lngRow = 1 To .Rows.Count
                    strName1 = .Cells(lngRow, 1)
                    strName2 = .Cells(lngRow, 2)

                    If strName1 amp; strName2 = "" Then
                        lngBlanks = lngBlanks   1
                    Else
                        lngBlanks = 0

                        If strName1 = strName Then strNameToAdd = strName2
                        If strName2 = strName Then strNameToAdd = strName1

                        If Not objNames.Exists(strNameToAdd) And strNameToAdd <> "" Then objNames.Add strNameToAdd, strNameToAdd
                    End If

                    If lngBlanks = 10 Then Exit For
                Next

                lngStart = lngStart   1
            Next
        Loop
    End With

    For i = 0 To objNames.Count - 1
        GetAssociatedNames = Trim(GetAssociatedNames amp; "," amp; objNames.Keys(i))
    Next

    GetAssociatedNames = Replace(Mid(GetAssociatedNames, 2), ",", ", ")
End Function
  

… затем добавьте ссылку на среду выполнения сценариев Microsoft Scripting …

Затем вы можете использовать формулу в ячейке, например, таким образом …

У меня это сработало, и я надеюсь, что у вас это сработает.