Pesquise uma string e os valores de saída correspondentes a essa string

Eu sugeriria criar um Dicionário de todos os recursos. Cada entrada nesse Dicionário de recurso obtém novamente um Dicionário de todas as tarefas das quais o recurso precisa cuidar.

Somente após a construção do Dicionário completo, ele será despejado na planilha de resultados.

Se você não estiver familiarizado com Dicionários: Há muita documentação por aí, por exemplo aqui . Observe que estou usando ligação antecipada, portanto, você deve adicionar uma referência ao Microsoft Scripting Runtime.

O código para construir o dicionário de recursos é bastante direto. Por motivos de velocidade, primeiro leio os dados completos Table1em uma matriz bidimensional (chamei-a de data). Em seguida, o código percorre todas as linhas de todas as colunas de recursos e lê o nome do recurso. Se não estiver no dicionário (é "novo"), criamos um novo Dicionário ( taskDict) para a entrada. Em seguida, a tarefa é adicionada ao Dicionário de tarefas e o recurso é adicionado ao Dicionário de recursos.

Function fillResourceDict() As Dictionary
    
    ' (1) Read data from table1
    Dim data As Variant
    Dim lastRow As Long, row As Long
    Dim lastCol As Long, col As Long
    
    With ThisWorkbook.Sheets("Table1")
        lastRow = .Cells(.Rows.Count, 2).End(xlUp).row
        lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
        
        data = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
        ' Fill in empty values in column 1 (because of the unholy merged cells)
        For row = 3 To lastRow
            If IsEmpty(data(row, 1)) Then data(row, 1) = data(row - 1, 1)
        Next row
    End With

    ' (2) Build the resouce-Dictionary. Loop over all recource columns
    Dim resourceDict As New Dictionary
    For row = 3 To lastRow
        For col = 3 To lastCol
            Dim resource As String, task As String, taskDict As Dictionary
            resource = data(row, col)
            If resource <> "" Then
                If resourceDict.Exists(resource) Then
                    ' Read the taskDict from existing resource
                    Set taskDict = resourceDict(resource)
                Else
                    ' New resource: Create a new Dictionary
                    Set taskDict = New Dictionary
                End If
                task = data(row, 1) & "-" & data(row, 2)
                taskDict(task) = task    ' add Task
                Set resourceDict(resource) = taskDict
            End If
        Next col
    Next row
            
    Set fillResourceDict = resourceDict
End Function

Agora tudo o que resta fazer é chamar esta função e preencher o resultado na tabela2:

Sub fillToDoList()
    
    Dim resourceDict As Dictionary
    Set resourceDict = fillResourceDict
    
    With ThisWorkbook.Sheets("Table2")
        .UsedRange.ClearContents
        Dim resource As Variant, row As Long
        .Cells(1, 1) = "Resource"
        .Cells(1, 2) = "ToDo list"
        row = 2
        
        For Each resource In resourceDict.Keys
            .Cells(row, 1) = resource
            Dim taskDict As Dictionary
            Set taskDict = resourceDict(resource)
            .Cells(row, 2).Resize(1, taskDict.Count).Value = taskDict.Keys
            row = row + 1
        Next
    End With
End Sub

dados de transformação

Option Explicit

Sub GenerateResources()
    
    ' Constants
    
    Const SRC_SHEET As String = "Table1"
    Const SRC_MAIN_COLUMN As Long = 1
    Const SRC_SUB_COLUMN As Long = 2
    Const SRC_FIRST_DATA_CELL As String = "A2"
    Const DST_SHEET As String = "Table2"
    Const DST_FIRST_TABLE_CELL As String = "A1"
    Const DST_HEADERS As String = "Resource,To-Do List"
    Const DST_MAIN_SUB_DELiMiTER As String = "-"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    Dim sfCell As Range: Set sfCell = sws.Range(SRC_FIRST_DATA_CELL)
    
    Dim srg As Range:
    
    With sfCell.CurrentRegion
        Set srg = sfCell.Resize(.Row + .Rows.Count - sfCell.Row, _
            .Column + .Columns.Count - sfCell.Column)
    End With

    Dim scCount As Long: scCount = srg.Columns.Count
    
    If scCount < 3 Then
        MsgBox "Not enough columns.", vbCritical
        Exit Sub
    End If
    
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim sData(): sData = srg.Value
    
    ' Unique resources to the keys, and the resources' rows to the keys
    ' of another (inner) dictionary held by each item of the outer dictionary.
    
    Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
    rDict.CompareMode = vbTextCompare
    
    Dim sr As Long, sc As Long, rStr As String, rMaxCount As Long
    
    For sr = 1 To srCount
        For sc = 1 To scCount
            If sc <> SRC_MAIN_COLUMN And sc <> SRC_SUB_COLUMN Then
                rStr = CStr(sData(sr, sc))
                If Len(rStr) > 0 Then
                    If Not rDict.Exists(rStr) Then
                        Set rDict(rStr) = CreateObject("Scripting.Dictionary")
                    End If
                    If Not rDict(rStr).Exists(sr) Then
                        rDict(rStr)(sr) = Empty
                        If rDict(rStr).Count > rMaxCount Then
                            rMaxCount = rDict(rStr).Count
                        End If
                    End If
                End If
            End If
        Next sc
    Next sr
    
    Dim dcCount As Long: dcCount = rDict.Count + 1
    
    If dcCount = 1 Then
        MsgBox "No resources found.", vbCritical
        Exit Sub
    End If
    
    ' Join mains and subs. Each row to the keys and each 'join' to the items
    ' of a dictionary
    
    Dim msDict As Object: Set msDict = CreateObject("Scripting.Dictionary")
    
    Dim mStr As String, cmStr As String, sStr As String, tStr As String
    Dim IsMainFound As Boolean
    
    For sr = 1 To srCount
        mStr = CStr(sData(sr, SRC_MAIN_COLUMN))
        If IsMainFound Then
            If Len(mStr) = 0 Then
                mStr = cmStr
            Else
                cmStr = mStr
            End If
            sStr = CStr(sData(sr, SRC_SUB_COLUMN))
            If Len(sStr) > 0 Then
                tStr = mStr & DST_MAIN_SUB_DELiMiTER & sStr
                msDict(sr) = tStr
            End If
        Else
            If Len(mStr) > 0 Then
                IsMainFound = True
                sr = sr - 1
            End If
        End If
    Next sr
    
    ' Using the information from the dictionaries,
    ' generate the destination (result) array.
    
    Dim dData(): ReDim dData(1 To msDict.Count + 1, 1 To dcCount)
    
    Dim dHeaders() As String: dHeaders = Split(DST_HEADERS, ",")
    dData(1, 1) = dHeaders(0)
    dData(1, 2) = dHeaders(1)
    
    Dim dr As Long: dr = 1
    
    Dim orKey, irKey, dc As Long
    
    For Each orKey In rDict.Keys
        dr = dr + 1
        dData(dr, 1) = orKey
        dc = 1
        For Each irKey In rDict(orKey).Keys
            If msDict.Exists(irKey) Then
               dc = dc + 1
               dData(dr, dc) = msDict(irKey)
            End If
        Next irKey
    Next orKey

    ' Destination

    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_TABLE_CELL)
    Dim drg As Range: Set drg = dfCell.Resize(dr, dcCount)
    
    With drg
        
        ' Clear and write.
        .EntireColumn.Clear
        .Value = dData
        
        ' Format.
        
        ' Merge and center second header.
        With .Resize(1, dcCount - 1).Offset(, 1)
            .Merge
            .HorizontalAlignment = xlCenter
        End With
        ' All borders
        .Borders.Weight = xlThin
        ' All headers
        With .Resize(1)
            .Font.Bold = True
        End With
        ' All entire columns
        With .EntireColumn
            .AutoFit
            ' Resource columns only
            With .Resize(, dcCount - 1).Offset(, 1)
                .ColumnWidth = 4
            End With
        End With
        ' Resource data only (no headers)
        With .Resize(dr - 1, dcCount - 1).Offset(1, 1)
            .HorizontalAlignment = xlCenter
        End With
        
        ' etc.
    
    End With
    
    MsgBox "Resources generated.", vbInformation
    
End Sub