[blackeangel]

Iska, есть вот такой код, по словам автора он, в какой то степени решает мою задачу. Но объяснять код отказался. Может вы что скажете дельного?

Код:

Option Explicit
'
'Код для Лист1
'
Dim cl As New Collection
 
Private Sub CommandButton2_Click()
    '
    'Поиск приближенных совпадений
    '
    Dim i&, j&, ii&, jj&, s$, try&, v, CurR&, CurC&
    Dim yes&
    On Error Resume Next 'Включаем игнор ошибок
    Set cl = New Collection 'Инициализируем коллекцию
    CurR = 14 'Сюда будем писать результаты начиная с 14-й строки
    
    With Sheets("лист3") 'Заполняем коллекцию для искомых данных
        ii = .Cells(Rows.Count, 1).End(xlUp).Row 'Определение последней заполненной строки
        jj = .Cells(1, Columns.Count).End(xlToLeft).Column 'Определение последнего столбца
        For i = 1 To ii: For j = 1 To jj
            For try = 3 To 100
                s = Space(try): RSet s = .Cells(i, j)
                Err.Clear: cl.Add .Cells(i, j), s
                If Err = 0 Then Exit For 'Выход если ключ не занят
            Next
        Next j, i
    End With
    
    With Sheets("лист2")
        ii = .Cells(Rows.Count, 1).End(xlUp).Row 'Определение последней заполненной строки
        jj = .Cells(1, Columns.Count).End(xlToLeft).Column 'Определение последнего столбца
        For i = 1 To ii: For j = 1 To jj
            yes = 0
            For try = 3 To 100
                s = Space(try): RSet s = .Cells(i, j)
                Err.Clear
                v = cl(s)
                If Err Then Exit For 'Эта ошибка возникает если совпадений более нет
                yes = 1
                With Sheets("лист1")
                    CurC = (try - 3) * 3
                    .Cells(CurR, 1 + CurC).Value = s
                    .Cells(CurR, 2 + CurC).Value = v
                End With
            Next
            CurR = CurR + yes
        Next j, i
    End With
    
 
End Sub
 
Sub RWord(Range As Range)
    '
    'Случайное слово с точкой и цифрой
    '
    Dim i&, j&, s$
    s = Space(20)
    For i = 1 To 3
        Mid$(s, i, 1) = Chr(97 + Fix(Rnd * 26))
    Next: Mid$(s, i, 1) = "."
    For i = i + 1 To i + 3 + Fix(Rnd * 3)
        Mid$(s, i, 1) = Fix(Rnd * 10)
    Next
    Range.Value = RTrim$(s)
End Sub
 
Private Sub CommandButton1_Click()
    '
    'Создание двух таблиц со случайными значениями
    '
    Dim i&, j&
    With Sheets("лист2")
        .Cells.ClearContents
        For i = 1 To 100: For j = 1 To 10
            RWord .Cells(i, j)
        Next j, i
    End With
    With Sheets("лист3")
        .Cells.ClearContents
        For i = 1 To 200: For j = 1 To 20
            RWord .Cells(i, j)
        Next j, i
    End With
End Sub
 
 
Private Sub CommandButton3_Click()
    With Sheets("лист1")
        .Rows("14:" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    End With
End Sub