匹配，复制和粘贴其他工作表

Question

我是VBA excel的新手。我打算从数据库中找到匹配的值，并将数据复制到另一个工作表。下面的代码是有效的，但经过几次尝试后它就停止了运行。我的excel文件损坏了吗？或者代码错了。

Sub match()
Dim lastrow As Long
    lastrow = ThisWorkbook.ActiveSheet.Cells(ThisWorkbook.ActiveSheet.Rows.Count, "A").End(xlUp).Row
Dim searchlist As Range
    Dim rcell As Range, sValue As String
    Dim lcol As Long, cRow As Long
    Dim dRange As Range, sCell As Range
    Dim d As Long

    Set searchlist = Sheets("sheet2").Range("a5:a" & lastrow)

    Set dRange = Sheets("Database").Range("a1:a" & lastrow)
    For Each rcell In searchlist
        lcol = 1 

        For Each sCell In dRange
            If InStr(1, sCell.Value, rcell.Value) And Trim(rcell.Value) <> "" Then


                For d = 1 To 22
                rcell.Offset(0, lcol).Value = sCell.Offset(0, d).Value
                lcol = lcol + 1
             Next
            End If
        Next
    Next

End Sub

Answer 1

请替换此代码：

If InStr(1, sCell.Value, rcell.Value) And Trim(rcell.Value) <> "" Then 

到

If InStr(1, sCell.Value, rcell.Value) > 0 And Trim(rcell.Value) <> "" Then

希望得到这个帮助。