仅从同一行复制相邻的单元格值，而不复制其他行，无论 Instr 函数的重复结果如何

Question

我不知道如何编写我的困境。下面是我当前的代码，它非常适合比较 Sheet 3 Col B 和 Sheet 2 Col B。一旦在两个 Col B's 之间找到匹配项，代码就会从 Sheet 3 Col A 和 C 复制相邻的单元格，并将答案粘贴到 Sheet 2 Col分别为 A 和 D。

Sub ID()
Dim sheet1 As Worksheet, sheet2 As Worksheet, Sheet3 As Worksheet
    Dim isFound As Boolean: isFound = False
    Set sheet1 = Sheets(1)
    Set sheet2 = Sheets(2)
    Set Sheet3 = Sheets(3)
    Dim Sheet3ColB, Sheet2ColB As Variant
    Dim ii As Long, tt As Long, w As Long: w = 3
    Sheet3ColA = Sheet3.Range("A2:C" & Sheet3.Cells(Sheet3.Rows.Count, 2).End(xlUp).Row).Value2
    Sheet2ColB = sheet2.Range("B3:B" & sheet2.Cells(sheet2.Rows.Count, 2).End(xlUp).Row).Value2
    For ii = LBound(Sheet2ColB) To UBound(Sheet2ColB)
        isFound = False
        For tt = LBound(Sheet3ColA) To UBound(Sheet3ColA)
            'perform case insensitive (partial) comparison
            If InStr(1, LCase(Sheet2ColB(ii, 1)), LCase(Sheet3ColA(tt, 2))) > 0 Then
                 sheet2.Cells(w, 1) = Sheet3ColA(tt, 1)
                 sheet2.Cells(w, 4) = Sheet3ColA(tt, 3)
                w = w + 1
                isFound = True
            End If
        Next
        If Not isFound Then
            sheet2.Cells(w, 2) = Sheet2ColB(ii, 1)
            w = w + 1
        End If
    Next

End Sub

我唯一的问题是我的数据会有一些重复。因此，当 Instr 函数运行时，它将针对单行返回多个值（最多只返回几次）。但我需要的只是代码从当时正在比较的行中复制和粘贴，仅此而已 - 所以只有相关行中的信息。我的建议是这样，但它返回一个错误：

sheet2.Cells(w, 1) = Sheet3ColA(tt & Cells.row, 1)
sheet2.Cells(w, 4) = Sheet3ColA(tt & Cells.row, 3)

我需要它做的就是只获取 Sheet 3 中同一行的数据并将该信息仅粘贴到 sheet 2 中，而忽略所有其他可能在数据上方/下方重复。

Answer 1

一旦找到匹配项，就不需要进一步使用内部循环，所以我的建议是

Sub ID()
Dim sheet1 As Worksheet, sheet2 As Worksheet, Sheet3 As Worksheet
    Dim isFound As Boolean: isFound = False
    Set sheet1 = Sheets(1)
    Set sheet2 = Sheets(2)
    Set Sheet3 = Sheets(3)
    Dim Sheet3ColB, Sheet2ColB As Variant
    Dim ii As Long, tt As Long, w As Long: w = 3
    Sheet3ColA = Sheet3.Range("A2:C" & Sheet3.Cells(Sheet3.Rows.Count, 2).End(xlUp).Row).Value2
    Sheet2ColB = sheet2.Range("B3:B" & sheet2.Cells(sheet2.Rows.Count, 2).End(xlUp).Row).Value2
    For ii = LBound(Sheet2ColB) To UBound(Sheet2ColB)
        isFound = False
        For tt = LBound(Sheet3ColA) To UBound(Sheet3ColA)
            'perform case insensitive (partial) comparison
            If InStr(1, LCase(Sheet2ColB(ii, 1)), LCase(Sheet3ColA(tt, 2))) > 0 Then
                 sheet2.Cells(w, 1) = Sheet3ColA(tt, 1)
                 sheet2.Cells(w, 4) = Sheet3ColA(tt, 3)
                w = w + 1
                isFound = True
                Exit for
            End If
        Next
        If Not isFound Then
            sheet2.Cells(w, 2) = Sheet2ColB(ii, 1)
            w = w + 1
        End If
    Next

End Sub