查找匹配数据带入sheet1的数据不完整

cmo9020

请导师们帮忙看一下代码问题
SHEET1 A2单元格输入查找匹配SHEET2,SHEET3 A列
带入数据到sheet1（有重复全部都带入）
在寻找D列单元格内,把有MOIN-加上第1位英文加上4位数字
反红色粗体字

现在sheet1的D列数据有些Moin-XXXX后面若是没有字符串,它不会反红
而且有的时候查找带入到sheet1的数据也不完整


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$A$2" Then
        Dim wb As Workbook
        Dim col As Collection
        Dim i As Integer, j As Long
        Dim arr, s

        Set wb = ThisWorkbook
        Set col = New Collection

        wb.Worksheets("Sheet1").Range("B2:H100").Clear

        j = wb.Worksheets("Sheet2").Range("A65536").End(xlUp).Row
        With wb.Worksheets("Sheet2")
            arr = .Range("A1:g" & j)
            For i = 2 To j
                col.Add arr(i, 1) & "/" & arr(i, 2) & "/" & arr(i, 3) & "/" & arr(i, 4) & "/" & arr(i, 5) & "/" & arr(i, 6)
            Next
        End With

        j = wb.Worksheets("Sheet3").Range("A65536").End(xlUp).Row
        With wb.Worksheets("Sheet3")
            arr = .Range("A1:g" & j)
            For i = 2 To j
                col.Add arr(i, 1) & "/" & arr(i, 2) & "/" & arr(i, 3) & "/" & arr(i, 4) & "/" & arr(i, 5) & "/" & arr(i, 6)
            Next
        End With

        Dim matchCount As Integer
        matchCount = 0

        For i = 1 To col.count
            If InStr(1, col(i), Target.Value) > 0 Then
                s = Split(col(i), "/")

                Target.Offset(matchCount, 1) = s(2)
                Target.Offset(matchCount, 2) = s(3)
                Target.Offset(matchCount, 3) = s(4)
                Target.Offset(matchCount, 4) = s(5)

                matchCount = matchCount + 1
            End If
        Next i

        If matchCount = 0 Then
            MsgBox "抱歉，找不到??的型?！"
        End If


        Dim regex As Object
        Dim matches As Object
        Dim match As Object
        Dim startPos As Long
        Dim endPos As Long
        Dim cell As Range
        Dim Line As Variant

        Set regex = CreateObject("VBScript.RegExp")
        regex.Global = True
        regex.Pattern = "MOIN-[A-Za-z]{1}\d{4}"

        For Each cell In Range("D2:D" & Cells(Rows.count, "D").End(xlUp).Row)
            Dim lines() As String
            lines = Split(cell.Value, vbLf)

            For Each Line In lines
                Set matches = regex.Execute(Line)

                For Each match In matches
                    startPos = InStr(1, Line, match.Value)
                    endPos = startPos + Len(match.Value) - 1
                    cell.Characters(startPos + InStr(1, cell.Value, Line) - 1, Len(match.Value)).Font.Bold = True
                    cell.Characters(startPos + InStr(1, cell.Value, Line) - 1, Len(match.Value)).Font.Color = RGB(255, 0, 0)
                Next match
            Next Line
        Next cell

        Set wb = Nothing
        Set col = Nothing
        Set regex = Nothing
        Set matches = Nothing
        Set match = Nothing
    End If
End Sub

半百

不知道理解的对不对