Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Выбор наиболее точного совпадения при поиске из нескольких
 
#1
25.02.2021 10:56:54
Добрый день.
Для поиска совпадений из списка использую функцию ПРОСМОТР, однако столкнулся с рядом ее минусов ( основной в том, что берет первое значение с конца списка)
Сам список значений сортировать нет возможности, поэтому нужно как то заменить или модернизировать данный способ поиска.

Нужна ваша помощь в поиске решения для наиболее приемлемого поиска по ключу в списке.

Приложил файл пример, в котором показаны три варианта как хотелось бы видеть результаты поиска, а так же пример использования функции ПРОСМОТР, которая не дает верных результатов

Идеальная логика поиска для меня:

Сначала проверить полное совпадение ключа в списке,
если да, то вывести совпадение

если нет, то проверить находится ли ключ в начале текста для поиска,
если да, то выводить наиболее близкое значение(меньшее по остаточным символам) и (если возможно) выписывать все остальные совпадения в строку по возрастанию символов
если нет, то выводить совпадения по наименьшему числу символов до и после ключа

Ключей может быть >1000
Список может быть >10000

По этому хотелось бы использовать минимальное количество циклов или, быть может, все куда проще, просто я об этом не знаю

Решение приемлемо на вба или формулой

Заранее спасибо откликнувшимся!
 
 
 
#2
25.02.2021 13:53:33
VBA решение для варианта 1.
Код
Sub Var1()
    Dim vList As Variant
    Dim aList As Variant
    aList = Range("Таблица1[Список]")
    
    Dim vKey As Variant
    Dim aKey As Variant
    aKey = Range("Таблица1[Ключ]")
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim curLen As Long
    Dim arr As Variant
    
    Dim yOut As Long
    
    For Each vKey In aKey
        For Each vList In aList
            If vKey <> "" Then
                If Left(vList, Len(vKey)) = vKey Then
                    Debug.Print vKey, vList
                    curLen = Len(vList) - Len(vKey)
                    If dic.Exists(vKey) Then
                        arr = dic.Item(vKey)
                        If arr(0) > curLen Then
                            dic.Item(vKey) = Array(curLen, vList)
                        End If
                        Erase arr
                    Else
                        dic.Item(vKey) = Array(curLen, vList)
                    End If
                End If
            End If
        Next
        yOut = yOut + 1
        If dic.Exists(vKey) Then Range("Таблица1[Совпадение]").Cells(yOut, 1).Value = dic.Item(vKey)(1)
    Next
End Sub
 
 
 
#3
25.02.2021 13:57:54
Для варианта 2.
Код
Sub Var2()
    Dim vList As Variant
    Dim aList As Variant
    aList = Range("Таблица2[Список]")
    
    Dim vKey As Variant
    Dim aKey As Variant
    aKey = Range("Таблица2[Ключ]")
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim curLen As Long
    Dim arr As Variant
    
    Dim yOut As Long
    
    For Each vKey In aKey
        For Each vList In aList
            If vKey <> "" Then
                If InStr(vList, vKey) > 0 Then
                    curLen = Len(vList) - Len(vKey)
                    If dic.Exists(vKey) Then
                        arr = dic.Item(vKey)
                        If arr(0) > curLen Then
                            dic.Item(vKey) = Array(curLen, vList)
                        End If
                        Erase arr
                    Else
                        dic.Item(vKey) = Array(curLen, vList)
                    End If
                End If
            End If
        Next
        yOut = yOut + 1
        If dic.Exists(vKey) Then
            Range("Таблица2[Совпадение]").Cells(yOut, 1).Value = dic.Item(vKey)(1)
        Else
            Range("Таблица2[Совпадение]").Cells(yOut, 1).ClearContents
        End If
    Next
End Sub
 
 
 
#4
25.02.2021 14:23:21
Для третьего варианта.
Код
Sub Var3()
    Dim vList As Variant
    Dim aList As Variant
    aList = Range("Таблица24[Список]")
    
    Dim vKey As Variant
    Dim aKey As Variant
    aKey = Range("Таблица24[Ключ]")
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim curLen As Long
    Dim arr As Variant
    
    Dim yOut As Long
    Dim y As Long
    
    For Each vKey In aKey
        ReDim arr(LBound(aList, 1) To UBound(aList, 1), 1 To 2)
        y = LBound(arr, 1)
        For Each vList In aList
            If vKey <> "" Then
                If Left(vList, Len(vKey)) = vKey Then
                    curLen = Len(vList) - Len(vKey)
                    If Left(vList, Len(vKey & "-01")) = vKey & "-01" Then curLen = 1
                    
                    arr(y, 2) = curLen
                    arr(y, 1) = vList
                    y = y + 1
                End If
            End If
        Next
        yOut = yOut + 1
        If y > 1 Then
            SortArray arr, 2
            arr = ShiftArr(arr)
            Range("Таблица24[Совпадение 1]").Cells(yOut, 1).Resize(1, UBound(arr, 1)).Value = Application.Transpose(arr)
        Else
            Range("Таблица24[Совпадение 1]").Cells(yOut, 1).Resize(1, UBound(aList, 1)).ClearContents
        End If
    Next
End Sub

Function ShiftArr(ar1 As Variant) As Variant
    Dim ar2 As Variant
    ReDim ar2(LBound(ar1, 1) To UBound(ar1, 1), LBound(ar1, 2) To UBound(ar1, 2))
    Dim y1 As Long
    Dim y2 As Long
    y2 = LBound(ar2, 1)
    For y1 = LBound(ar1, 1) To UBound(ar1, 1)
        If ar1(y1, 1) <> "" Then
            ar2(y2, 1) = ar1(y1, 1)
            y2 = y2 + 1
        End If
    Next
    ShiftArr = ar2
End Function

Sub SortArray(arr As Variant, iColumn As Integer)
    'Сортировка расчёской
    Dim d As Long
    Dim bNextTurnExit As Boolean: bNextTurnExit = False
    
    Dim i As Long
    Dim j As Long
    Dim t As Variant
    Dim x As Integer
    
    Dim dh As Double
    dh = UBound(arr, 1) - LBound(arr, 1)
    If dh < 1 Then Exit Sub
    Do
        dh = dh / 1.247
        d = Round(dh, 0)
        
        If bNextTurnExit Then d = 1
        i = LBound(arr, 1)
        Do
            j = i + d
            If j > UBound(arr, 1) Then Exit Do
            If arr(i, iColumn) > arr(j, iColumn) Then
                
                For x = LBound(arr, 2) To UBound(arr, 2)
                    t = arr(j, x)
                    arr(j, x) = arr(i, x)
                    arr(i, x) = t
                Next
                
            End If
            i = i + 1
            DoEvents
        Loop
        
        If bNextTurnExit Then Exit Do
        If d <= 1 Then bNextTurnExit = True
    Loop
    
End Sub
 
 
 
#5
26.02.2021 10:37:47
На малых объемах прекрасно работает решение. Спасибо за варианты, МатросНаЗебре.
НО, при использовании варианта 3 на списке из 900 строк и 813 ключей затраченное время составило 27 минут, что, конечно, совсем уже много.( обновление экрана было выключено)
Хотелось бы как то ускорить процесс.
Может имеет смысл заменить внутренний цикл функцией FIND, или же она не быстрее перебора массива?
 
 
 
#6
26.02.2021 12:12:06
На малых объемах прекрасно работает решение. Спасибо за варианты, МатросНаЗебре.
НО, при использовании варианта 3 на списке из 900 строк и 813 ключей затраченное время составило 27 минут, что, конечно, совсем уже много.( обновление экрана было выключено)

Заменил внутренний цикл поиска по списку, операцией .FIND, время прогона того же объема уменьшилось до 9.5 минут, но хотелось бы еще быстрее.

Может подскажет кто варианты?
Код
With activeworkbook.activesheet.ListObjects("Таблица24").ListColumns(2).DataBodyRange
          Set c = .Find(vKey, LookIn:=xlValues)
          If Not c Is Nothing Then
            firstResult = c.Address
            Do
                If vKey <> "" Then
                    If Left(c, Len(vKey)) = vKey Then
                        curLen = Len(c) - Len(vKey)
                        arr(y, 2) = curLen
                        arr(y, 1) = c
                        y = y + 1
                    End If
                End If
                Set c = .Find(vKey, After:=c, LookIn:=xlValues)
                If c Is Nothing Then Exit Do
                Loop While c.Address <> firstResult
          End If
        End With
 
 
 
#7
26.02.2021 12:37:39
Tech-01, может поможет мой вариант или штатный
Макрос можно ускорить в разы, но ваши условия слишком узкоспециализированы (нужно только вам), чтобы копаться в этом …
Изменено: Jack Famous - 26.02.2021 12:39:27
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#8
26.02.2021 12:49:55
Так должно быть чуть быстрее.
Код
Sub Var3()
    Dim vList As Variant
    Dim aList As Variant
    Dim aLis2 As Variant
    aList = Range("Таблица24[Список]")
    SortArray aList, 1
    
    Dim vKey As Variant
    Dim aKey As Variant
    aKey = Range("Таблица24[Ключ]")
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim curLen As Long
    Dim arr As Variant
    
    Dim yOut As Long
    Dim y As Long
    Dim y1 As Long
    Dim y2 As Long
    Dim y3 As Long
    
    For Each vKey In aKey
        yOut = yOut + 1
        y = 0
        
        If Not IsEmpty(vKey) Then
            y1 = -1
            y2 = -1
            For y3 = LBound(aList, 1) To UBound(aList, 1)
                If Left(aList(y3, 1), Len(vKey)) = vKey Then
                    If y1 = -1 Then y1 = y3
                    y2 = y3
                Else
                    If y1 <> -1 Then Exit For
                End If
            Next
        
            If y1 <> -1 Then
                ReDim aLis2(1 To y2 - y1 + 1, 1 To 1)
                For y3 = y1 To y2
                    aLis2(y3 - y1 + 1, 1) = aList(y3, 1)
                Next
            
                ReDim arr(LBound(aLis2, 1) To UBound(aLis2, 1), 1 To 2)
                y = LBound(arr, 1)
                For Each vList In aLis2
    '                If vKey <> "" Then
    '                    If Left(vList, Len(vKey)) = vKey Then
                            curLen = Len(vList) - Len(vKey)
                            If Left(vList, Len(vKey & "-01")) = vKey & "-01" Then curLen = 1
                            
                            arr(y, 2) = curLen
                            arr(y, 1) = vList
                            y = y + 1
    '                    End If
    '                End If
                Next
            End If
        End If
        
        If y > 1 Then
            SortArray arr, 2
            arr = ShiftArr(arr)
            Range("Таблица24[Совпадение 1]").Cells(yOut, 1).Resize(1, UBound(arr, 1)).Value = Application.Transpose(arr)
        Else
            Range("Таблица24[Совпадение 1]").Cells(yOut, 1).Resize(1, UBound(aList, 1)).ClearContents
        End If
        
    Next
End Sub
 
 
 
#9
26.02.2021 13:17:54
Доброе время суток
Цитата
Tech-01 написал:
до 9.5 минут
Что-то действительно долго. На наборе 900 ключей, 9000 значений (каждому ключу по 10 :) ) 10 секунд по первой задаче - и это тупой перебор по декартовому произведению таблиц на начинается с. И по третьей тоже 10.
Updated.
Версия на Power Query.
Изменено: Андрей VG - 26.02.2021 13:29:45
 
 
 
Страницы: 1
Наверх