Найти несколько совпадений

Question

Первый столбец моей таблицы - это список названий команд. Следующие несколько столбцов содержат имена игроков. Игрок может быть в более чем одной команде. Наконец, у меня есть колонка со списком имен игроков.

Я хотел бы пройтись по списку игроков и выяснить, в какие команды входит каждый игрок. Заказ не важен

Как я могу это сделать?

Например, учитывая:

red | tom | bob | sally | emma
blue | tom | george | bill | sally
green | george | bob
yellow | sally| arthur | george | emma

Я хотел бы, чтобы результат был:

tom | red | blue
bob | red | green
sally | red | blue | yellow
george | blue | green | yellow
arthur | yellow
emma | yellow | red

Answer 1

Для этого вам нужно будет включить VBA. Затем вы хотите вставить это в свой редактор VBA после чего-либо еще:

Sub CreateWorksheet_TransposedListing(inputData As Range, worksheetName As String)
    AddNumberedSheet worksheetName
    Dim new_sheet As Worksheet
    Set new_sheet = Sheets(Sheets.Count)
    Dim nRowDx As Integer, nColDx As Integer
    Dim sValue As String, sHeader As String, sAddress As String
    For nRowDx = 1 To inputData.Rows.Count
        For nColDx = 1 To inputData.Columns.Count
            If nColDx = 1 Then
                sValue = Trim(inputData.Cells(nRowDx, nColDx).Value)
            Else
                sHeader = Trim(inputData.Cells(nRowDx, nColDx).Value)
                sAddress = FindNextHeaderCell(new_sheet.Name, sHeader)
                If sAddress = "" Then Exit Sub
                new_sheet.Range(sAddress) = sValue
            End If
        Next
    Next
End Sub

Function FindNextHeaderCell(sSheet As String, sRowHeaderName As String) As String
    Dim nRowDx As Integer, nColDx As Integer
    For nRowDx = 1 To 32766
        If IsEmpty(Worksheets(sSheet).Cells(nRowDx, "A")) Then
            Worksheets(sSheet).Cells(nRowDx, "A") = sRowHeaderName
            FindNextHeaderCell = Worksheets(sSheet).Cells(nRowDx, "B").Address
            Exit Function
        ElseIf Worksheets(sSheet).Cells(nRowDx, "A") = sRowHeaderName Then
            For nColDx = 2 To 32766
                If IsEmpty(Worksheets(sSheet).Cells(nRowDx, nColDx)) Then
                    FindNextHeaderCell = Worksheets(sSheet).Cells(nRowDx, nColDx).Address
                    Exit Function
                End If
            Next
            If nColDx > 32766 Then
                MsgBox "This result is larger than VBA will support. Results have been truncated."
                FindNextHeaderCell = ""
                Exit Function
            End If
        End If
    Next
    If nRowDx > 32766 Then
        MsgBox "This result is larger than VBA will support. Results have been truncated."
    End If
    FindNextHeaderCell = ""
End Function

Sub AddNumberedSheet(Optional sWorksheetName As String, Optional bSelectWorksheet As Boolean)
    Dim sheet_name As String, num_text As String
    Dim i As Integer, new_num As Integer, max_num As Integer
    Dim new_sheet As Worksheet
    max_num = 0
    For i = 1 To Sheets.Count
        sheet_name = Sheets(i).Name
        If Left$(sheet_name, Len(sWorksheetName)) = sWorksheetName Then
            num_text = Mid$(sheet_name, Len(sWorksheetName) + 1)
            new_num = Val(num_text)
            If new_num > max_num Then max_num = new_num
        End If
    Next i
    Set new_sheet = Sheets.Add(after:=Sheets(Sheets.Count))
    new_sheet.Name = sWorksheetName & Format$(max_num + 1)
    If bSelectWorksheet Then new_sheet.Select
End Sub

Затем вы хотите добавить метод, который вызывает его. Например, если у вас есть кнопка, вы бы использовали что-то вроде этого:

Sub Button1_Click()
    CreateWorksheet_TransposedListing Range("A1:E4"), "TestSheet"
End Sub