Re: Search and Extract specific values from columns
Try this code, which you should put in a standard module:
Public Sub Create_Deal_Summary()
Dim NamesCells As Range, cell As Range
Dim names As Variant
Dim i As Integer
Dim NamesDict As Object 'Scripting.Dictionary
Dim DealsDict As Object 'Scripting.Dictionary
Dim name As String, deal As String
Dim NamesKeys As Variant
Dim numDealsColumns As Integer
'Create dictionary to hold Names. This is the parent dictionary, and each key will be a distinct
'Name value, and each item will be a child dictionary of associated Deals. For these child
'dictionaries, each key will be a distinct Deal string, and each item will be the same Deal string
'Set NamesDict = New Scripting.Dictionary 'early binding of MS Scripting Runtime
Set NamesDict = CreateObject("Scripting.Dictionary")
'Define Names starting in Sheet1 E2 as a range
With Worksheets("Sheet1")
Set NamesCells = Range(.Range("E2"), .Cells(Rows.Count, "E").End(xlUp))
End With
'Loop through the Names cells
For Each cell In NamesCells
names = Split(cell.Value, ",")
deal = cell.Offset(0, -2).Value 'Get Deal from column C
'Loop through comma-separated Names in this cell
For i = 0 To UBound(names)
name = Trim(names(i))
Debug.Print cell.Address, name, deal
'If this Name exists in the Names dictionary, then see if the associated
'Deal exists in the child Deals dictionary
If NamesDict.Exists(name) Then
Set DealsDict = NamesDict.Item(name)
'If this Deal does not exist in the Deals dictionary, then add the Deal, using
'the Deal string as both the key and the item value
If Not DealsDict.Exists(deal) Then
DealsDict.Add deal, deal
End If
Else
'This Name doesn't exist in the Names dictionary, so create:
'1. The child Deals dictionary containing the first Deal associated with the Name
'2. A new item in the Names dictionary for this Name and its linked Deals dictionary
'Set DealsDict = New Scripting.Dictionary 'early binding
Set DealsDict = CreateObject("Scripting.Dictionary")
DealsDict.CompareMode = vbTextCompare
DealsDict.Add deal, deal
NamesDict.Add name, DealsDict
End If
Next
Next
'Output the results to Sheet2 starting at A2
NamesKeys = NamesDict.Keys
numDealsColumns = 0
With Worksheets("Sheet2").Range("A2")
.Parent.Cells.Clear
'Write all the distinct Names (i.e. the Names dictionary's keys) to cell A2 downwards
.Resize(NamesDict.Count, 1).Value = Application.Transpose(NamesKeys)
'Loop through the Names dictionary keys
For i = 0 To UBound(NamesKeys)
'Write all the Deals strings for this Names dictionary key along the row
Set DealsDict = NamesDict.Item(NamesKeys(i))
.Offset(i, 1).Resize(1, DealsDict.Count).Value = DealsDict.Keys
If DealsDict.Count > numDealsColumns Then numDealsColumns = DealsDict.Count
Next
'Put column headings in row 1 - A1, then B1 to the maximum number of deals
.Offset(-1, 0).Value = "Name"
For i = 1 To numDealsColumns
.Offset(-1, i).Value = "Deals " & i
Next
.Parent.Columns.AutoFit
End With
End Sub
Display More
PS - I think you've made a mistake in repeating CIBC in the Sheet2 output data, otherwise my results don't exactly match yours.
