Страницы: 1
RSS
Перебор вариантов из словаря и запись подходящей строки, Перебор вариантов из словаря и запись подходящей строки
 
Привет, всем.
Есть ячейки с многострочным текстом (столбец А) и есть некий набор строк с ключевыми словами (столбец D) которые необходимо искать в этом многострочном тексте и в случае совпадения в столбец "Необходимый продукт" выводить всю строку в которой присутствует ключевое слово.
Заранее Спасибо!
 
Zhen Zhen, для примера
Код
Sub mrshkei()
Dim arr, arr2, arr3, i As Long, lr As Long, n As Long, k As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A2:A" & lr)
arr3 = Range("D2:D4")
For i = LBound(arr) To UBound(arr)
    arr2 = Split(arr(i, 1), Chr(10))
    For n = LBound(arr2) To UBound(arr2)
        For k = LBound(arr3) To UBound(arr3)
            If InStr(1, arr2(n), arr3(k, 1), vbTextCompare) > 0 Then arr(i, 1) = arr2(n): GoTo M
        Next k
    Next n
M:
Next i
Range("B2").Resize(UBound(arr), 1) = arr
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
Спасибо, хотелось бы формулой решать этот вопрос

Вот здесь по сути мое решение, но оно не работает с многострочным текстом в ячейке и видит лишь полное совпадение, а я не могу сообразить как сделать для многострочного текста
https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=8&TID=29141
Изменено: vikttur - 23.06.2021 12:47:30
 
Код
Sub Apple()
    Dim dic As Object
    Set dic = GetDic(Sheets(1).Range("D2:D4"))
    
    With ActiveSheet
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim r As Range
        Set r = .Range(.Cells(2, 1), .Cells(y, 2))
    End With
    
    Dim arr As Variant
    Dim brr As Variant
    Dim b As Variant
    Dim v As Variant
    arr = r
    
    Dim res As Object
    
    For y = 1 To UBound(arr, 1)
        brr = Split(arr(y, 1), vbLf)
        Set res = CreateObject("Scripting.Dictionary")
        For Each b In brr
            For Each v In dic.Keys
                If InStr(LCase(b), v) > 0 Then
                    res.Item(res.Count) = b
                End If
            Next
        Next
        arr(y, 2) = Join(res.Items(), vbLf)
        Set res = Nothing
    Next
    r = arr
    
End Sub

Function GetDic(r As Range) As Object
    Dim arr As Variant
    If r.Cells.Count = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = r.Value
    Else
        arr = r
    End If
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim y As Long
    For y = 1 To UBound(arr, 1)
        If arr(y, 1) <> "" Then dic.Item(LCase(arr(y, 1))) = 0
    Next
    Set GetDic = dic
End Function
 
Zhen Zhen, попробуйте обойтись без цитирования: Оно в #3 абсолютно неуместно.
Страницы: 1
Наверх