Question

我有一张名为Input的表。顶行A1：O1包含父级，下面（不同长度）的行包含URL。一些URL在父母之间共享，我想返回一个URL列表，以及他们父母的内容。我尝试过连接（如果（索引（匹配，但公式变得太大。我见过的类似问题都只是一个输出，通常是一个数字。我对VBA解决方案持开放态度，但对创建的理解非常少）我自己的代码。

例：
新闻---名人----金融
CNN ------复杂--------福布斯福布斯--- CNN

我想回归CNN新闻名人，福布斯新财经，复杂名人。我不介意这个输出是如何格式化的。

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以外的列结尾，你可以用“lastHeadCol + 2”替换上面代码中的“17”。 VBA将获得带有标题的最后一个使用的列（比如列E，即第5列），然后在G列（第7列，又名5 + 2）中添加URL等。从技术上讲，这是一种更好的代码方式，因为它更少依赖于“硬编码”（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

如果列包含特定字符串，则返回标题

2 个答案: