Возврат заголовков, если столбец содержит определенную строку

Question

У меня есть лист под названием Input. Верхняя строка, A1: O1 содержит родительский элемент, а строки под (различной длины) содержат URL-адреса. Некоторые из URL-адресов разделяются между родителями, и я хочу вернуть список URL-адресов и их родителей. Я попробовал concatenate (if (index (match, но формула становится слишком большой). Аналогичные вопросы, которые я видел, ищут только один вывод, как правило, число. Я открыт для решений VBA, но имею очень минимальное понимание для создания мой собственный код

. Пример:
Новости --- Знаменитости ---- Финансы
CNN ------ комплекс -------- Forbes
Forbes --- CNN

Я хочу вернуть CNN News Celebrity, Forbes New Finance, Complex Celebrity. Я не против, как этот выход отформатирован.

Answer 1

Поскольку у вас есть данные в A: O, я предполагаю, что столбец Q пуст. В столбце Q введите список уникальных значений (поэтому в вашем примере Q1 является «CNN», Q2 «Complex», а Q3 - «Forbes». Вы можете использовать «удалить дубликаты», чтобы получить список уникальных URL-адресов). Этот код будет цикл через используемый диапазон от столбца A до O (от строки 2 до последней использованной строки), а затем поставить «ответ» в колонке 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 

Там могут быть проблемы - такие, как, скажем, ваш блок адресов заканчивается в строке 90, но у вас есть несвязанные данные в строке 99, это собирается установить диапазон идти вниз до 99 - если это так, то вы можете изменить «lastRow» в

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

Помогает ли это?

Редактировать: Если в будущем у вас есть код, который заканчивается в столбце, отличном от O, вы можете заменить «17» в этом коде выше на «lastHeadCol + 2». VBA получит последний использованный столбец с заголовком (скажем, столбец E, который является 5-м столбцом), а затем добавьте URL-адреса и т. Д. В столбце G (7-й столбец, ака 5 + 2). Это технически лучший способ сделать код, поскольку он меньше полагается на что-то «жестко закодированное» (aka "magic numbers").

Answer 2

Я создал функцию VBA, которая должна делать именно это. На основе моего другого function аналогичного характера. Не изящно, но выполняет свою работу.

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 

Назад, с более запятыми *, чем когда-либо прежде, конечный поиск URL **.
* извините чувак, ты серовато сказал форматирование не имеет никакого значения
** ограничения применяются, см комментарии

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