如何做相似名字对比？

以下是全名比较的代码，现在需要新增按钮做相似名字对比的代码，请高手帮忙！！！（以下代码有tanchuhan提供）

相似名字对比要求：
有2个文本框text1和text2，要求后期输入内容，例如在text1中输入4000个名字，在text2中输入1000个名字，而且是每个姓名占据一行，然后通过按钮确认进行比较（逐行名字比较），如果text2中有相似的名字在text1中出现，则该名字输出到text3中；如果text2中的有相似的名字不在text1中出现，则该名字输出到text4中！

注：相似名字是3个字姓名中有2个字相同。

（压缩包内有2个文本的名字做数据对比参考用）.





Private Sub Command1_Click()
    Text3.Text = ""
    Text4.Text = ""
    
    '需要比较的两组文本及它们的上界
    Dim a() As String, b() As String
    Dim al As Long, bl As Long
    a = Split(Text1.Text, vbNewLine)
    b = Split(Text2.Text, vbNewLine)
    al = UBound(a)
    bl = UBound(b)
    
    '保证小数组在前
    If al = -1 Or bl = -1 Then Exit Sub
    If al > bl Then
        Dim tmp() As String
        Dim tmpl As Long
        
        tmp = a
        a = b
        b = tmp
        
        tmpl = al
        al = bl
        bl = tmpl
    End If
    
    '按大数组长度声明两个数组用来保存结果，并记录其实际长度
    Dim c() As String, d() As String
    Dim cl As Long, dl As Long
    ReDim c(bl), d(bl)
    cl = 0
    dl = 0
    
    '循环比较
    Dim i As Long, j As Long
    For i = 0 To al
    
        Dim item As String
        item = a(i)
    
        Dim contain As Boolean
        contain = False
        For j = 0 To bl
            If item = b(j) Then
                contain = True
                Exit For
            End If
        Next
        
        '保存结果
        If contain Then
            c(cl) = item
            cl = cl + 1
        Else
            d(dl) = item
            dl = dl + 1
        End If
        
    Next
    
    '去掉多余的元素，拼接成字符串显示
    If cl > 0 Then
        ReDim Preserve c(cl - 1)
        Text3.Text = Join(c, vbNewLine)
    End If
    
    If dl > 0 Then
        ReDim Preserve d(dl - 1)
        Text4.Text = Join(d, vbNewLine)
    End If
End Sub