Помогите решить задачу века

[Ivan.Z]

Добрый день и прекрасной весны всем.
Подскажите добрые люди а то замучался я с этим вопросом.
Есть два прайса (1 выгружен из 1с одной фирмы) ( другой из интерент мгаазина )
Есть строчки с названием товара в одном и с названием товара в другом
Но есть загвоздка они отличаются, надо найти схожие значения.
Например прайс 1 (откуда надо брать значения)
Вело 14" Зайка 145-F, синий
-----------------
Прайс 2 (где надо найти похожее значение)
Велосипед детский, Зайка 145-F, синий.

[Ivan.Z]

Прикрпил файл дв котором надо сравнить и выделить значения похожие чтобы включить данный товар в магазине

[Oldy7]

Частичное решение:
- составляются наборы карт-ключей в которых список цифровых вхождений в строку разделенных пробелами
- с помощью двух словарей сравниваются ключи
- по результатам сравнения (если есть совпадения) идет выгрузка данных на "лист2"

Одна беда - таких совпадений мало)

Макрос это делающий:

Sub test()
Dim DC1 As Object, DC2 As Object, txt$, dt$, a&, b%, c%, arr()
Dim arr1(), rr&(), x1&, x2&, z&
Dim sh As Worksheet, aa As Range, bb As Range, cc As Range
arr = Sheets(1).[a2].CurrentRegion.Value
Set DC1 = CreateObject("Scripting.Dictionary")
Set DC2 = CreateObject("Scripting.Dictionary")
For a = 2 To UBound(arr)
  If NumExT(arr(a, 1), dt) Then
    If Not DC1.exists(dt) Then
      ReDim rr(1 To 1): rr(1) = a: DC1.Add dt, rr
    Else
      rr = DC1.Item(dt): ReDim Preserve rr(1 To UBound(rr) + 1)
      rr(UBound(rr)) = a: DC1.Item(dt) = rr
    End If
  End If
  If NumExT(arr(a, 2), dt) Then
    If Not DC2.exists(dt) Then
      ReDim rr(1 To 1): rr(1) = a: DC2.Add dt, rr
    Else
      rr = DC2.Item(dt): ReDim Preserve rr(1 To UBound(rr) + 1)
      rr(UBound(rr)) = a: DC2.Item(dt) = rr
    End If
  End If
Next
arr1 = DC1.keys()
Set sh = Sheets(2): Set aa = sh.[a1]: Set bb = sh.[b1]
sh.Columns("A:B").Clear
x1 = 1: x2 = 1
For a = 0 To UBound(arr1)
  If DC2.exists(arr1(a)) Then
    If UBound(DC1.Item(arr1(a))) > UBound(DC2.Item(arr1(a))) Then
      z = UBound(DC1.Item(arr1(a)))
    Else: z = UBound(DC2.Item(arr1(a)))
    End If
    Set cc = Intersect(sh.Columns("A:B"), sh.Rows(x1 & ":" & x1 + z - 1))
    cc.Borders.LineStyle = xlContinuous: cc.Borders.Weight = xlMedium
    cc.Borders(xlInsideVertical).Weight = xlThin
    cc.Borders(xlInsideHorizontal).Weight = xlThin
    rr = DC1.Item(arr1(a))
    For c = 1 To UBound(rr): aa.Offset(x1 - 1, 0) = arr(rr(c), 1): x1 = x1 + 1: Next
    rr = DC2.Item(arr1(a))
    For c = 1 To UBound(rr): bb.Offset(x2 - 1, 0) = arr(rr(c), 2): x2 = x2 + 1: Next
    If x1 > x2 Then x2 = x1 Else x1 = x2
  End If
Next
sh.Columns("A:B").AutoFit
End Sub
'-----------------------------------------------
Function NumExT(ByVal txt$, dt$) As Boolean
Dim a&, b&, nn$, ll&, c&, arr$()
c = 0: dt = vbNullString: nn = "#": ll = Len(txt)
If ll = 0 Then NumExT = False: Exit Function
ReDim arr(1 To ll / 2 + 1): a = 1
Do
  Do Until Mid$(txt, a, 1) Like "#"
    a = a + 1
    If a > ll Then Exit Do
  Loop
  If a > ll Then Exit Do
  c = c + 1: nn = "##": b = 2
  Do While Mid$(txt, a, b) Like nn
    nn = nn & "#": b = b + 1
  Loop
  arr(c) = Mid$(txt, a, b - 1): a = a + b - 1
Loop While a < ll
If c > 0 Then
  ReDim Preserve arr(1 To c): dt = Join(arr, " "): NumExT = True
Else: ReDim arr(1 To 1)
End If
End Function

[Oldy7]

Ну или более мягкий фильтр.

[Ivan.Z]

А теперь скажите пожалуйста как этим пользоваться, спасибо.

[Oldy7]

Сообщение от Ivan.Z

как этим пользоваться

А на какие мысли Вас натолкнула большая синяя кнопка на первом листе файла выше?

[Ivan.Z]

Сообщение от Oldy7

А на какие мысли Вас натолкнула большая синяя кнопка на первом листе файла выше?

Я пытался нажимать её, растягивать, пока не понял если честно ) Я просто ну прям нуб в этих вопросах сильно не ругайте подскажите я быстро обучаюсь )

[Oldy7]

Excel, настройки, параметры безопасности, разрешить макросы.

[Ivan.Z]

Елы палы на 2 листе ответ ) Понятно а какой столбец из какой колонки ) Спасибо хотя бы на этом буду тестить как он работает ! Выручили!