比较子串与整个字符串 - 分裂函数高级

Question

我的代码非常适用于将工作表2 （Col B）的范围与工作表1 中的（col A）范围进行比较。找到匹配后，它会将第1页（第B栏）中的相邻值复制到第2页（第C栏）。

  

Sheet 1 Sheet 2 Sheet 2 current output

我唯一的问题是代码不适用于（第1页中的col A）在每个单元格中有多个单词的情况。

关于如何让代码比较单个单词（它适用于哪个单词），以及按顺序和相邻地查找和比较两个单词的任何建议？例如，如果我在表1（Col A）中有“温度斜坡”，并且我在（Col B）表2 中有“执行温度斜坡”，我希望代码能够找到“温度斜坡”。

这是另外代码，比较（Col A）中的单个单词。

表格示例和此代码给出的解决方案如下：代码删除温度斜坡，但我需要它一起识别两个单词，如果没有识别它保持在那里的行而不删除它？

Sub x()

    Dim v, vOut(), i As Long, j As Long, k As Long, va, r As Range, r1 As Long

    With Sheets("Sheet 1") 'Assumes list of words in A1/B1 and down on "Sheet 1"
        Set r = .Range("A1").CurrentRegion
    End With

    With Sheets("Sheet 2") 'Assumes phrases in B1 and down on "Sheet 2"
        v = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Value
        .Columns(2).ClearContents
    End With

    ReDim vOut(1 To UBound(v) * r.Rows.Count, 1 To 2)

    For i = LBound(v, 1) To UBound(v, 1)
        va = Split(v(i, 1))
        For j = LBound(va) To UBound(va)
           For r1 = 1 To r.Rows.Count
            If LCase(Application.Trim(va(j))) Like "*" & LCase(r.Cells(r1, 1)) Then

            'If LCase(Application.Trim(va(j))) = LCase(r.Cells(r1, 1)) Then
                k = k + 1
                vOut(k, 1) = v(i, 1)
                vOut(k, 2) = r.Cells(r1, 2)
            End If
           Next r1
        Next j
    Next i

    Sheets("Sheet 2").Range("B3").Resize(k, 2) = vOut 'Puts results in B1/C1 and down on "Sheet2"

    End Sub

Answer 1

试试这个，这与你的逻辑类似。评论中的必要注释。

Sub CustomCopy()
    Dim sheet1 As Worksheet, sheet2 As Worksheet, Sheet1ColA As Variant, Sheet2ColB As Variant
    Dim i As Long, j As Long, k As Long: k = 3
    Dim isFound As Boolean: IsFound = False
    Set sheet1 = Sheets(1)
    Set sheet2 = Sheets(2)
    'read both columns
    Sheet1ColA = sheet1.Range("A1:B" & sheet1.Cells(sheet1.Rows.Count, 1).End(xlUp).Row).Value2
    Sheet2ColB = sheet2.Range("B3:B" & sheet2.Cells(sheet2.Rows.Count, 2).End(xlUp).Row).Value2
    'clear second and third column in second sheet
    sheet2.Range("B3:B" & sheet2.Cells(sheet2.Rows.Count, 2).End(xlUp).Row).Clear
    sheet2.Range("C3:C" & sheet2.Cells(sheet2.Rows.Count, 2).End(xlUp).Row).Clear
    For i = LBound(Sheet2ColB) To UBound(Sheet2ColB)
        isFound = False
        For j = LBound(Sheet1ColA) To UBound(Sheet1ColA)
            'perform case insensitive (partial) comparison
            If InStr(1, LCase(Sheet2ColB(i, 1)), LCase(Sheet1ColA(j, 1))) > 0 Then
                sheet2.Cells(k, 2) = Sheet2ColB(i, 1)
                sheet2.Cells(k, 3) = Sheet1ColA(j, 2)
                k = k + 1
                isFound = True
            End If
        Next
        If Not isFound Then
            sheet2.Cells(k, 2) = Sheet2ColB(i, 1)
            k = k + 1
        End If
    Next

End Sub