Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
В большом количество данных найти неявные дубли
 
#1
14.05.2021 07:27:47
Есть ли возможность реализовать поиск частичного совпадения.
страница 1 исходные данные
aaa1111aa111aaa
a1111a111a11
1111a1111aaa1111
Что бы без ввода данных сам показывал где есть совпадение
результат выделяется
Может макрос есть?
aaa1111aa111aaa
a1111a111a11
1111a1111aaa1111
Спасибо
 
 
 
#2
14.05.2021 07:59:53
Андрей Метелёв, пример в файле что есть и что должно получится в итоге
пока ответ тот же функция ПОИСК
по вашему уточнению о выделении части текста то это только макрос
Лень двигатель прогресса, доказано!!!
 
 
 
#3
14.05.2021 08:16:39
не вводить данные что надо искать, а он сам определяет дубли. Отлично было бы если выделял разным цветом разные дубли. Задача такова больше количество данных надо найти неявные дубли (в ячейки по 1-20 слов в разно порядке) есть совпадения например только 1 слово или 2 и надо что бы он его подсвечивал. Даже не знаю как правиль задать вопрос))) Может еще что есть, как можно находить неявные дубли?
 
 
 
#4
14.05.2021 09:07:47
Выделите диапазон, запустите макрос.
Код
Sub FindDouble()
    FindDoubleInRange Selection
End Sub

Sub FindDoubleInRange(o As Range)
    Dim r As Range
    On Error Resume Next
    Set r = Intersect(o, ActiveSheet.UsedRange)
    On Error GoTo 0
    If Not r Is Nothing Then
        Dim c1 As Range
        Dim c2 As Range
        Dim col As Long
        r.Font.ColorIndex = xlAutomatic
        Randomize
        For Each c1 In r
            col = RGB(255 * Rnd(), 255 * Rnd(), 255 * Rnd())
            For Each c2 In r
                If c1.Address <> c2.Address Then
                    If c1.Value <> "" Then
                        If InStr(c2.Value, c1.Value) > 0 Then
                            c1.Font.Color = col
                            c2.Font.Color = col
                        End If
                    End If
                End If
            Next
        Next
    End If
End Sub
Изменено: МатросНаЗебре - 14.05.2021 09:08:19
 
 
 
#5
14.05.2021 09:34:18
СПАСИБО ОГРОМНОЕ!!!
 
 
 
#6
16.05.2021 01:55:43
МатросНаЗебре  
Уважаемый, хороший макрос, но с большим объёмом работать появляются тормоза на долго. Можно ли прибавить к этому макросу дополнение для ускорения, чтобы не зависал.
Если можно, то весь код с дополнением для ускорения и с возможностью работать с большой базой данных, чтоб не висла.

Спасибо Вам большое!
 
 
 
#7
17.05.2021 17:29:04
Так будет побыстрее, но мгновенно всё равно не будет.
Код
Sub FindDouble()
    FindDoubleInRange Selection
End Sub
 
Sub FindDoubleInRange(o As Range)
    Dim r As Range
    On Error Resume Next
    Set r = Intersect(o, ActiveSheet.UsedRange)
    Set r = r.Areas(1)
    On Error GoTo 0
    If Not r Is Nothing Then
    If r.Cells.Count > 1 Then
        Dim arr As Variant
        arr = r
        
        Dim arrCol As Variant
        ReDim arrCol(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        
        
        Dim c1 As Range
        Dim c2 As Range
        Dim col As Long
        r.Font.ColorIndex = xlAutomatic
        Randomize
        
        Dim y1 As Long
        Dim x1 As Integer
        Dim y2 As Long
        Dim x2 As Integer
        
        For y1 = 1 To UBound(arr, 1)
        For x1 = 1 To UBound(arr, 2)
            If Not IsEmpty(arr(y1, x1)) Then
                col = RGB(255 * Rnd(), 255 * Rnd(), 255 * Rnd())
                For y2 = 1 To UBound(arr, 1)
                For x2 = 1 To UBound(arr, 2)
                    If y1 = y2 And x1 = x2 Then
                    Else
                        If InStr(arr(y2, x1), arr(y1, x1)) > 0 Then
                            arrCol(y1, x1) = col
                            arrCol(y2, x2) = col
                        End If
                    End If
                    DoEvents
                Next
                Next
            End If
        Next
        Next
        
        For y1 = 1 To UBound(arr, 1)
        For x1 = 1 To UBound(arr, 2)
            If Not IsEmpty(arrCol(y1, x1)) Then
                r.Cells(y1, x1).Font.Color = arrCol(y1, x1)
            End If
            DoEvents
        Next
        Next
        
    End If
    End If
End Sub
 
 
 
#8
17.05.2021 18:43:58
👍🏻👍🏻👍🏻👍🏻👍🏻👍🏻👍🏻👍🏻👍🏻👍🏻👍🏻
 
 
 
#9
17.05.2021 18:51:27
Спасибо Вам, МатросНаЗебре!

Раньше выделялась группа чисел например двойки зелёным цветом, тройки другим цветом, ну и так далее, а сейчас выделяет  просто полностью строчку определённым цветом и не взаимосвязаны между собой. Первую строчку выделяет зелёным и вторую строку выделяет зелёным потому что наверно, что в первой строке есть одна цифра(2) так и во второй строке есть цифра 2.
Хотелось бы как раньше но побыстрей!

Спасибо Вам за объяснения и за помощь!
Надеюсь с Вашим опытом и талантом придём к намеченной цели!
 
 
 
Страницы: 1
Наверх