VBA文本数组 - 扫描两列以进行数组字符串匹配而不是一列

Question

我有一些代码用于扫描列F＆amp; G表示在数组中找到的单词，包含在第J列中找到的文本的数组。如果它在列F或列G中发现，则会将这些术语复制并粘贴到相应的列中。

列J包含SAP中字段的自由文本。该字段是自由文本，因此它可能是“Kerry John Pub Expenses”或“CATS O / H Kerry John”，甚至是“CATS John Kerry O / H”。该字段没有数据输入标准;这就是使这项任务变得困难的原因。

列F和列G包含名字和姓氏。代码假设，如果它在列F或G中找到与txt数组中的条目匹配的条目，它将复制并粘贴该条目。

在测试期间，代码证明不足以匹配我正在寻找的结果，并且该问题的解决方案是同时匹配列F和G中的文本以获得两个匹配的单词，而不是在单独的区间中进行。

我想就如何重写此代码以实现此结果提出一些建议。

成功运行代码的示例

这里我们有4行数据，John Citizen位于第3行，因此列F和G第2行中的空白单元格可以填充他的名字和姓氏。

问题

因为我有两行包含Kerry Citizen和John Kerry，所以该行填充了Kerry Kerry，其中条目应为F列中的“John”和G列中的“Kerry”

代码从这里开始

Sub arraycolumnmatch()
Dim txtArray As Variant, T As Variant
Dim I As Long, J As Long

For I = 2 To Range("E50000").End(xlUp).row
    typ = Range("F" & I).Value
    If typ = "" Then
        txt = Range("J" & I).Value
        txtArray = Split(txt, " ")

        For Each T In txtArray
            For J = 2 To Range("F50000").End(xlUp).row
                If Range("F" & J).Value = T Then
                    match_txt = T
                    Range("F" & I).Value = match_txt
                End If
            Next J
        Next T

        For Each T In txtArray
            For J = 2 To Range("G50000").End(xlUp).row
                If Range("G" & J).Value = T Then
                    match_txt = T
                    Range("G" & I).Value = match_txt
                End If
            Next J
        Next T
    End If
Next I
End Sub

Answer 1

以下代码针对列表中的每个名字运行，但仅在两个名称匹配时才添加名称。

    Sub arraycolumnmatch()
    Dim txtArray As Variant, t As Variant
    Dim I As Long, J As Long

    For I = 2 To Range("G50000").End(xlUp).Row
        typ = Range("F" & I).Value
        If typ = "" And Not Range("J" & I).Value = Empty Then
            txt = Range("J" & I).Value
            txtArray = Split(txt, " ")

            For Each word In txtArray
                If Not word = "" Then
                    Set findtext = Range("F:F").Find _
                    (what:=(word), LookIn:=xlValues)
                    stoploop = False
                    loopcnt = 0

                    Do While Not findtext Is Nothing And stoploop = False And loopcnt < 21
                        loopcnt = loopcnt + 1
                        If InStr(txt, Range("F" & findtext.Row).Value) <> 0 _
                            And InStr(txt, Range("G" & findtext.Row).Value) Then
                            'Both names match. Copy them.
                            Range("F" & I).Value = Range("F" & findtext.Row).Value
                            Range("G" & I).Value = Range("G" & findtext.Row).Value
                            stoploop = True
                            Exit For ' look no further.
                        Else
                            Set findtext = Range("F" & findtext.Row & ":F" & 50000).Find _
                            (what:=(word), LookIn:=xlValues)
                        End If
                    Loop
                End If
            Next word

                If Not stoploop Then MsgBox "No match found for: " & txt

        End If
    Next I
    End Sub

编辑：@Jean InStr与Find in Range的集成是否允许更少的循环时间和双匹配查找。

Answer 2

您可以大大简化代码，并使其正常工作，如下所示：

    typ = Range("F" & I).Value
    If typ = "" Then
        txt = Range("J" & I).Value

        matchFound = False
        For J = 2 To Range("G50000").End(xlUp).Row
            If InStr(txt, Range("F" & J).Value) <> 0 _
                And InStr(txt, Range("G" & J).Value)  _
                And Not (IsEmpty(Range("F" & J).Value)) _
                And Not (IsEmpty(Range("G" & J).Value)) Then

                'Both names match. Copy them.
                Range("F" & I).Value = Range("F" & J).Value
                Range("G" & I).Value = Range("G" & J).Value
                matchFound = True
                Exit For ' look no further.
            End If
        Next J

        If Not matchFound Then MsgBox "No match found for: " & txt

    End If

经过测试，适合我。

Answer 3

我不得不坚持原始语法，答案如下。不是达到结果的最有效方式，但它有效

    Sub arraycolumnmatch()
    Dim txtArray As Variant, T As Variant
    Dim I As Long, J As Long

    For I = 2 To Range("E50000").End(xlUp).row
        typ = Range("F" & I).Value
    If typ = "" Then
        txt = Range("J" & I).Value
        txtArray = Split(txt, " ")

        For Each T In txtArray
            For J = 2 To Range("G50000").End(xlUp).row
                If Range("G" & J).Value = T Then
                    match_txt = T
                    Range("G" & I).Value = match_txt
                    Exit For
                End If
            Next J
        Next T

        For Each T In txtArray
            For J = 2 To Range("F50000").End(xlUp).row
                If Range("F" & J).Value = T Then
                       match_txt = T
                       If Not Range("G" & I).Value = T Then
                          Range("F" & I).Value = match_txt
                          Exit For
                       End If
                End If
            Next J
        Next T
   End If
Next I