查找完全匹配时出错

Question

我有三张工作表，Sh1、Sh2、Sh3。 Sh3 是我的结果表。

我已将 N 列从 Sh1 复制到 E 列中的 Sh3。

我考虑 sheet3 的 E 列，然后比较 sheet2 的 A 列，如果匹配，则将结果复制到 F 列的 sheet3 中。

我能够找到匹配的列，但是，我有一些特殊情况，我无法解决。

我已经在图片中解释了它们。

[![The Image Shows an example of how the ID Looks in column E of sht3][1]][1]

![Here i have shown both structure of ID. The first row id is the same, and has no Problem ist finding the match. In the second row, there is an 0 less in my sheet2, and the code Fails to Display that, in row 3, the Id has an 0 extra in sheet2. in row 4, i have an id with other id, but in sheet2, i have the same id, with 0 extra, same in row 5 as well, The ID are generally 11 to 13 Digit Long. ]1

有人可以建议我如何克服这个问题。下面是代码，我用于将值从一张表复制到另一张表并在另一张表中查找值。

Sub lookup()
Dim lLastrow As Long
Dim rng As Range
Dim i As Long

ThisWorkbook.Sheets("S").Select
lLastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
Range("P5:P" & lLastrow).Copy Destination:=Sheets("Result_APQP").Range("E5")
Range("G5:G" & lLastrow).Copy Destination:=Sheets("Result_APQP").Range("H5")

Sheets("Result").Select
For i = 5 To lLastrow

Set rng = Sheets("P").UsedRange.Find(Cells(i, 5).Value & "*", LookAt:=xlWhole)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 6).Value = rng.Value
 End If
Next i
End Sub

Answer 1

我会这样做：

Sub clear(rng As Range)
    For Each cell In rng.Cells
        cell.Value = Split(cell.Value, ",")(0)
        cell.Value = Split(cell.Value, ";")(0)
        While Mid(cell.Value, Len(cell.Value)) = "0"
            cell.Value = Mid(cell.Value, 1, Len(cell.Value) - 1)
        Wend
    Next cell
End Sub


Sub lookup()
    Dim lLastrow As Long
    Dim rng As Range
    Dim i As Long

    ThisWorkbook.Sheets("S").Select
    lLastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
    Range("P5:P" & lLastrow).Copy Destination:=Sheets("Result_APQP").Range("E5")
    Range("G5:G" & lLastrow).Copy Destination:=Sheets("Result_APQP").Range("H5")

    Call clear(Sheets("Result").UsedRange)
    Call clear(Sheets("P").UsedRange)

    Sheets("Result").Select
    For i = 5 To lLastrow

        Set rng = Sheets("P").UsedRange.Find(Cells(i, 5).Value & "*", LookAt:=xlWhole)
        'If it is found put its value on the destination sheet
        If Not rng Is Nothing Then
            Cells(i, 6).Value = rng.Value
        End If
    Next i
End Sub

注意，clear() 子程序会修改原始数据。