Return headers if column contains certain string

Question

I have a sheet called Input. The top row, A1:O1 contains the parent, and the rows underneath (of varying length) contains URLs. Some of the URLs are shared between the parents, and I want to return a list of URLs, and what their parents are. I have tried concatenate(if(index(match but the formula becomes too large. Similar questions I've seen are all looking for just one output, usually a number. I am open to VBA solutions, but have very very minimal understanding to create my own code.

Example:
News --- Celebrity ---- Finance
CNN------Complex --------Forbes
Forbes---CNN

I want to return CNN News Celebrity, Forbes New Finance, Complex Celebrity. I don't mind how this output is formatted.

Answer 1

Since you have data in A:O, I am assuming that column Q is blank. In Column Q, make a list of the unique values (so in your example, Q1 is "CNN", Q2 is "Complex" and Q3 is "Forbes". You can use the "remove duplicates" to get a list of unique URLs). This code will loop through the used range from Column A to O (from row 2 to the last used row) and then put the "answer" in column R.

Sub test()
Dim headerRange As Range, uniqueName As String, i As Integer, totalNames As Integer, lastHeadCol As Integer, lastRow As Integer, cel As Range
Dim replaceString As String

lastRow = UsedRange.Rows.Count ' Find the last used row
lastHeadCol = Cells(1, 1).End(xlToRight).Column 'find the last column
totalNames = Cells(1, 17).End(xlDown).Row 'find out how many unique names there are
For i = 1 To totalNames
    uniqueName = Cells(i, 17).Value 'Get the unique name to check for in each column
    replaceString = uniqueName  'Start off the "answer" with the unique name
    For Each cel In Range(Cells(2, 1), Cells(lastRow, lastHeadCol)) ' for each cell in the range, starting at A2
        If cel.Value = uniqueName Then 'If that cell's value IS the unique name then
            replaceString = replaceString & " " & Cells(1, cel.Column).Value 'add that name to the string
            Cells(i, 17).Offset(0, 1).Value = replaceString ' update the "answer"
        End If
    Next cel

Next i

End Sub

There may be issues - such as let's say your block of URLs ends at row 90, but you have unrelated data in row 99, it's going to set the range to go down to 99 - if this is the case, you can change the "lastRow" to

lastRow = cells(1,1).End(xldown).Row

Does this help?

Edit: If, in the future, you have code that ends in a column other than O, you can replace the "17"s in that code above with "lastHeadCol + 2". VBA will get the last used column with a header (say Column E, which is the 5th column) and then add the URLs and such in column G (7th column, aka 5 + 2). That is technically a better way to do the code, since it relies less on something "hard-coded" (aka "magic numbers").

Answer 2

I made a VBA function that is supposed to do just this. Based on my other function of similar nature. Not elegant but does the job.

Public Function FINDHEADERWHERESUBSTRINGFITS(Target As Range, Condition As String)
Dim rng As Range
NumCols = Target.Columns.Count 'counts how many header values we can choose of
Dim Headers() 'defines separate arrays for headers and values (turned out to be obsolete, see variable x)
    ReDim Headers(1 To NumCols)
Dim ValuesArr()
    ReDim ValuesArr(1 To NumCols)

HeaderRow = Target.Row 'row in which headers are located
LastRow = HeaderRow + Target.Rows.Count - 1 'last row with values
FirstColumn = Target.Column 'first column with values
LastColumn = FirstColumn + Target.Columns.Count - 1 'last column with values

For k = FirstColumn To LastColumn 'for each column
    i = i + 1 'set array position

    For Each rng In Range(Cells(HeaderRow, k), Cells(LastRow, k)) 'for each value
        If rng.Row <> HeaderRow Then 'I mean value, not header
            If InStr(Condition, CStr(rng.Value2)) > 0 Then Headers(i) = Cells(HeaderRow, k).Value2 'if it's a substring of the condition then set the corresponding header
        End If
    Next
Next
FINDHEADERWHERESUBSTRINGFITS = Replace(Replace(Join(Headers, ","), ",,", ","), ",,", ",")
End Function

Back, with more commas* than ever before, the ultimate URL finder**.
*sorry dude, you dun' said formatting was irrelevant
**restrictions apply, see comments

Public Function FINDHEADERWHERESUBSTRINGFITS(Target As Range, Condition As String)
Dim rng As Range

HeaderRow = Target.Row 'row in which headers are located
LastRow = HeaderRow + Target.Rows.Count - 1 'last row with values
FirstColumn = Target.Column 'first column with values
LastColumn = FirstColumn + Target.Columns.Count - 1 'last column with values

NumCols = Target.Columns.Count 'counts how many header values we can choose of
NumCells = Target.Cells.Count - (LastColumn - FirstColumn + 1) 'counts how many URLs we can choose of

Dim Headers() 'defines separate arrays for headers and values
    ReDim Headers(1 To NumCols)
Dim ValuesArr()
    ReDim ValuesArr(1 To NumCells)
For k = FirstColumn To LastColumn 'for each column
    i = i + 1 'set array position
    For Each rng In Range(Cells(HeaderRow + 1, k), Cells(LastRow, k)) 'for each value
        If rng.Row <> HeaderRow Then 'I mean value, not header
            If InStr(CStr(rng.Value2), Condition) > 0 Then
            Headers(i) = Cells(HeaderRow, k).Value2 'if it's a substring of the condition then set the corresponding header
            j = j + 1 'increases the array position counter by one (not to overwrite the previous entry)
            ValuesArr(j) = CStr(rng.Value2) 'inserts URL to array position
            End If
        End If
    Next
Next

FINDHEADERWHERESUBSTRINGFITS = Replace(Replace(Join(Headers, ","), ",,", ","), ",,", ",") & "; " & Replace(Replace(Join(ValuesArr, ","), ",,", ","), ",,", ",")
End Function