Exel макрос поиска совпадений

[Present]

Здравствуйте, нужен макрос для exel, чтобы искал совпадения ФИО в ячейках одного столбца с ячейками другого, и ставил напротив совпавшей ячейки что-нибудь, например "совпадение". Но в некоторых ячейках записаны не только ФИО, но и еще что-то после. Поэтому нужно сделать сравнение по первому (желательно по первым 2-3 словам дабы избежать случаев с однофамильцами). Вот что у меня получилось:

Код: Выделить всё

Sub Macros2w2on3()
Dim k As Integer, t As Integer, Pos1 As Integer, Pos2 As Integer
Dim SStr As String, StSurname As String, SStr1 As String, StSurname1 As String
k = 0
Do
k = k + 1
For t = 1 To 211
SStr = Sheets("fiz").Cells(k, 2).Value
Pos1 = InStr(1, SStr, " ")
StSurname = Mid(SStr, 1, Pos1)
SStr1 = Sheets("Лист3").Cells(t, 2).Value
Pos2 = InStr(1, SStr, " ")
StSurname1 = Mid(SStr1, 1, Pos2)
If StSurname = StSurname1 Then Sheets("fiz").Cells(k, 4).Value = "Совпадение"
Next
Loop Until Sheets("fiz").Cells(k + 1, 2).Value = "Stop it now"
End Sub

Проблема в том, что "Совпадение" ставится не только напротив совпадающих ячеек, но и напротив пустых, а также тех в которых содержится только 1 слово. Подскажите пожалуйста в чем я ошибся, вроде что-то с InStr...

[RayShade]

Код: Выделить всё

Sub Macros2w2on3()
Dim j as Integer, k As Integer, t As Integer
Dim SStr() As String, SStr1() As String
Dim flag as boolean
Do
k = k + 1
For t = 1 To 211
if Len(Sheets("fiz").Cells(k, 2).Value)>0
SStr = Split(Sheets("fiz").Cells(k, 2).Value," ")
SStr1 = Split(Sheets("Лист3").Cells(t, 2).Value," ")
flag=false
if UBound(SStr)=UBound(SStr1) then
for j=LBound(SStr) to 2
if SStr(j)<>SStr1(j) then
flag=false
exit for
end if
flag=true
next j
end if
if flag then Sheets("fiz").Cells(k, 4).Value = "Совпадение"
end if
Next
Loop Until Sheets("fiz").Cells(k + 1, 2).Value = "Stop it now"
End Sub


[Present]

Спасибо большое, но почему-то не работает , но добавил из вашего макроса строку

Код: Выделить всё

If Len(Sheets("fiz").Cells(k, 2).Value) > 0 Then

И перестал писать совпадения при пустых строках. Затем в своем скрипте изменил StSurname = Mid(SStr, 1, Pos1) на StSurname = Mid(SStr, 1, Pos1 + 1) и все заработало, теперь ставит как нужно. Вот итоговый макрос:

Код: Выделить всё

Sub Macros2w2on3()
Dim k As Integer, t As Integer, Pos1 As Integer, Pos2 As Integer
Dim SStr As String, StSurname As String, SStr1 As String, StSurname1 As String
k = 0
Do
k = k + 1
For t = 1 To 211
SStr = Sheets("fiz").Cells(k, 2).Value
Pos1 = InStr(1, SStr, " ")
StSurname = Mid(SStr, 1, Pos1 + 1)
SStr1 = Sheets("Лист3").Cells(t, 2).Value
Pos2 = InStr(1, SStr, " ")
StSurname1 = Mid(SStr1, 1, Pos2 + 1)
If Len(Sheets("fiz").Cells(k, 2).Value) > 0 Then
If StSurname = StSurname1 Then Sheets("fiz").Cells(k, 4).Value = "Совпадение"
End If
Next
Loop Until Sheets("fiz").Cells(k + 1, 2).Value = "stop it now"
End Sub

Спасибо за помощь.

[RayShade]

Хм. Странно что не работает. Интересно было бы посмотреть в чем дело Может, в том что тут ищутся только полные совпадения? Можно сделать и так, чтоб были только частичные, скажем.

[Present]

Да, похоже, что из-за сравнения ячеек полностью. Нет, ваш макрос компилируется, но как я писал выше в некоторых ячейках написано не только ФИО но и еще что-то, потому и нужно было, чтоб сравнивал по фамилиям (в идеале, конечно, фамилия + имя, т е 1 и 2 слово). Не очень понимаю как делать сравнение определенных слов, потому получиось только по первому слову...

[RayShade]

Ну вот как-то так:

Код: Выделить всё

    Sub Macros2w2on3()
    Dim j as Integer, k As Integer, t As Integer
    Dim SStr() As String, SStr1() As String
    Dim flag as boolean
    Do
    k = k + 1
    For t = 1 To 211
    if Len(Sheets("fiz").Cells(k, 2).Value)>0
    SStr = Split(Sheets("fiz").Cells(k, 2).Value," ")
    SStr1 = Split(Sheets("Лист3").Cells(t, 2).Value," ")
    flag=(SStr(0)=SStr1(0)) and (SStr(1)=SStr1(1)) ' Сравнение по 1 и 2 слову
    ' Сравнение по 1 слову только flag=(SStr(0)=SStr1(0))
    if flag then Sheets("fiz").Cells(k, 4).Value = "Совпадение"
    end if
    Next
    Loop Until Sheets("fiz").Cells(k + 1, 2).Value = "Stop it now"
    End Sub


[The_Prist]

А может так?

Код: Выделить всё

Sub FindMyValue()
    Dim SStr() As String
    Dim iFoundRng As Range
    Dim lLastRow As Long, lRow As Long

    lRow = 1
    lLastRow = Sheets("fiz").Cells.SpecialCells(xlLastCell).Row + 1
    Do While lRow <> lLastRow
        If Sheets("fiz").Cells(lRow, 2).Value <> "" Then
            SStr = Split(Sheets("fiz").Cells(lRow, 2).Value, " ")
            With Sheets("Лист3").Columns(2)
                Set iFoundRng = .Find(What:=SStr(0) & " " & SStr(1), LookIn:=xlValues, LookAt:=xlPart)
                If Not iFoundRng Is Nothing Then
                    Sheets("fiz").Cells(lRow, 4).Value = "Совпадение"
                End If
            End With
        End If
     lRow = lRow + 1
    Loop
End Sub

[RayShade]

Ну можно и так