Поиск совпадений слов

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Поиск совпадений слов (Макросы/Sub)

elesobv

Дата: Четверг, 27.07.2023, 16:18 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

Репутация: 0 ±

Замечаний: 0% ±

Добрый день!
Есть список с наименованием Товара - в столбце А наименование , которое использует Покупатель; в столбце В - наименование Поставщика. Товар поставщика = Товару покупателя, т.е. в А2 и В2 (А3 и В3, А4 и В4 и т.д.) указан один товар, но по-разному. Нужно выделить совпадение одинаковых слов по строкам.
Мой код не отрабатывает слова, после которых идет запятая , хотя использовала Replace. Как это можно исправить?
Я не профессионал, иногда пишу небольшие макросы для упрощения работы. Буду благодарна за решение.

[vba]

Код

Option Explicit
Sub ВыделитьСовпаденияВСтрокахПоСловам()
'в диалоговом окне выберите первый столбец текстовых строк, который необходимо сравнить, а затем щелкните значок OK кнопку.
'появится диалоговое окно, выберите второй столбец и нажмите кнопку OK

Dim xRg1 As Range
Dim xRg2 As Range
Dim xTxt As String
Dim xCell1 As Range
Dim xCell2 As Range
Dim i As Long

Dim vArr1
Dim vArr2

Dim lngCnt1 As Long
Dim lngCnt2 As Long
Dim s As String
Dim Предложение1 As String
Dim Предложение2 As String

Dim pos As Long
Dim sLen As Long

On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
lOne:
Set xRg1 = Application.InputBox("Range A:", "Kutools for Excel", xTxt, , , , , 8)
If xRg1 Is Nothing Then Exit Sub
If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
GoTo lOne
End If
lTwo:
Set xRg2 = Application.InputBox("Range B:", "Kutools for Excel", "", , , , , 8)
If xRg2 Is Nothing Then Exit Sub
If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
GoTo lTwo
End If
If xRg1.CountLarge <> xRg2.CountLarge Then
MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "Kutools for Excel"
GoTo lTwo
End If

Application.ScreenUpdating = False
xRg2.Font.ColorIndex = xlAutomatic

For i = 1 To xRg1.Count
Set xCell1 = xRg1.cells(i)
Set xCell2 = xRg2.cells(i)

Предложение1 = Replace(xCell1, ",", " "): Предложение1 = Replace(xCell1, ".", "")
Предложение1 = Application.Trim(Предложение1)

Предложение2 = Replace(xCell2, ",", " "): Предложение2 = Replace(xCell2, ".", "")
Предложение2 = Application.Trim(Предложение2)

vArr1 = Split(Предложение1, " ")
vArr2 = Split(Предложение2, " ")

For lngCnt1 = LBound(vArr1) To UBound(vArr1)
s = vArr1(lngCnt1)
sLen = Len(s)

pos = InStr(xCell2.Value, s)
For lngCnt2 = LBound(vArr2) To UBound(vArr2)
If vArr2(lngCnt2) = s Then
xCell2.Characters(pos, sLen).Font.Color = vbRed

' xCell2.Characters(pos, Len(s) - pos + 1).Font.Color = vbRed
Exit For
End If
Next lngCnt2
Next lngCnt1

Next

Application.ScreenUpdating = True

End Sub

[/vba]

Код

[/vba]elesobv

К сообщению приложен файл: spisok_naimenovanij.xlsx (10.4 Kb)

Ответить

СообщениеДобрый день!
Есть список с наименованием Товара - в столбце А наименование , которое использует Покупатель; в столбце В - наименование Поставщика. Товар поставщика = Товару покупателя, т.е. в А2 и В2 (А3 и В3, А4 и В4 и т.д.) указан один товар, но по-разному. Нужно выделить совпадение одинаковых слов по строкам.
Мой код не отрабатывает слова, после которых идет запятая , хотя использовала Replace. Как это можно исправить?
Я не профессионал, иногда пишу небольшие макросы для упрощения работы. Буду благодарна за решение.

[vba]

Код

[/vba]

Автор - elesobv
Дата добавления - 27.07.2023 в 16:18

MikeVol

Дата: Четверг, 27.07.2023, 18:00 | Сообщение № 2

Группа: Проверенные

Ранг: Обитатель

Сообщений: 378

Репутация: 81 ±

Замечаний: 0% ±

MSO LTSC 2021 EN

elesobv, Здравствуйте. Проблема в вашем коде связана с тем, что вы перезаписываете переменную Предложение1 и Предложение2 дважды, а также используете неправильно функцию Replace. Вам необходимо заменить значения в Предложение1 и Предложение2 только один раз и использовать результат для разделения на слова.
[vba]

Код

Option Explicit

Sub ВыделитьСовпаденияВСтрокахПоСловам_v2()
    Dim xRg1 As Range, xRg2 As Range
    Dim xCell1 As Range, xCell2 As Range
    Dim xTxt        As String
    Dim i           As Long

    Dim vArr1
    Dim vArr2

    Dim lngCnt1 As Long, lngCnt2 As Long
    Dim s           As String
    Dim Предложение1 As String, Предложение2 As String

    Dim pos As Long, sLen As Long

    On Error Resume Next

    If ActiveWindow.RangeSelection.Count > 1 Then
        xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
        xTxt = ActiveSheet.UsedRange.AddressLocal
    End If

lOne:
    Set xRg1 = Application.InputBox("Range A:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg1 Is Nothing Then Exit Sub

    If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lOne
    End If

lTwo:
    Set xRg2 = Application.InputBox("Range B:", "Kutools for Excel", "", , , , , 8)
    If xRg2 Is Nothing Then Exit Sub

    If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lTwo
    End If

    If xRg1.CountLarge <> xRg2.CountLarge Then
        MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "Kutools for Excel"
        GoTo lTwo
    End If

    Application.ScreenUpdating = False
    xRg2.Font.ColorIndex = xlAutomatic

    For i = 1 To xRg1.Count
        Set xCell1 = xRg1.Cells(i)
        Set xCell2 = xRg2.Cells(i)

        Предложение1 = xCell1.Value
        Предложение2 = xCell2.Value

        Предложение1 = Replace(Предложение1, ",", " ")
        Предложение1 = Replace(Предложение1, ".", "")
        Предложение1 = Application.Trim(Предложение1)

        Предложение2 = Replace(Предложение2, ",", " ")
        Предложение2 = Replace(Предложение2, ".", "")
        Предложение2 = Application.Trim(Предложение2)

        vArr1 = Split(Предложение1, " ")
        vArr2 = Split(Предложение2, " ")

        For lngCnt1 = LBound(vArr1) To UBound(vArr1)
            s = vArr1(lngCnt1)
            sLen = Len(s)

            pos = InStr(xCell2.Value, s)

            For lngCnt2 = LBound(vArr2) To UBound(vArr2)

                If vArr2(lngCnt2) = s Then
                    xCell2.Characters(pos, sLen).Font.Color = vbRed
                    Exit For
                End If

            Next lngCnt2

        Next lngCnt1

    Next

    Application.ScreenUpdating = True
End Sub

[/vba]
И то не все совпадения точно находит, кое что всё ещё пропускает, не видит. Посмотрим, может кто из Более Опытных подтянуться к вашей теме. Чем смог тем и помог. Удачи.

Код

[/vba]
И то не все совпадения точно находит, кое что всё ещё пропускает, не видит. Посмотрим, может кто из Более Опытных подтянуться к вашей теме. Чем смог тем и помог. Удачи.MikeVol

Ученик.
Одесса - Украина

Ответить

Сообщениеelesobv, Здравствуйте. Проблема в вашем коде связана с тем, что вы перезаписываете переменную Предложение1 и Предложение2 дважды, а также используете неправильно функцию Replace. Вам необходимо заменить значения в Предложение1 и Предложение2 только один раз и использовать результат для разделения на слова.
[vba]

Код

Автор - MikeVol
Дата добавления - 27.07.2023 в 18:00

Hugo

Дата: Четверг, 27.07.2023, 18:20 | Сообщение № 3

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

[vba]

Код

Option Compare Text

[/vba]
помогает для
Кабель HARPER BCH-721 White
и нужно наверное сравнивать слова целиком, а то иногда закрашивает только одну букву в слове.

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Hugo

Дата: Четверг, 27.07.2023, 18:46 | Сообщение № 4

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3690

Репутация: 790 ±

Замечаний: 0% ±

365

Такой вариант вроде норм:
[vba]

Код

Option Explicit
Option Compare Text

Sub ВыделитьСовпаденияВСтрокахПоСловам_v2()
    Dim xRg1 As Range, xRg2 As Range
    Dim xCell1 As Range, xCell2 As Range
    Dim xTxt        As String
    Dim i           As Long

    Dim vArr1
    Dim vArr2

    Dim lngCnt1 As Long, lngCnt2 As Long
    Dim s           As String
    Dim Предложение1 As String, Предложение2 As String

    Dim pos As Long, sLen As Long

    On Error Resume Next

    If ActiveWindow.RangeSelection.Count > 1 Then
        xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
        xTxt = ActiveSheet.UsedRange.AddressLocal
    End If

lOne:
    Set xRg1 = Application.InputBox("Range A:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg1 Is Nothing Then Exit Sub

    If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lOne
    End If

lTwo:
    Set xRg2 = Application.InputBox("Range B:", "Kutools for Excel", "", , , , , 8)
    If xRg2 Is Nothing Then Exit Sub

    If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
        MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lTwo
    End If

    If xRg1.CountLarge <> xRg2.CountLarge Then
        MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "Kutools for Excel"
        GoTo lTwo
    End If

    Application.ScreenUpdating = False
    xRg2.Font.ColorIndex = xlAutomatic

    For i = 1 To xRg1.Count
        Set xCell1 = xRg1.Cells(i)
        Set xCell2 = xRg2.Cells(i)

        Предложение1 = xCell1.Value
        Предложение2 = xCell2.Value

        Предложение1 = Replace(Предложение1, ",", " ")
        Предложение1 = Replace(Предложение1, ".", "")
        'Предложение1 = Application.Trim(Предложение1)

        Предложение2 = Replace(Предложение2, ",", " ")
        Предложение2 = Replace(Предложение2, ".", " ")
        'Предложение2 = Application.Trim(Предложение2)

        vArr1 = Split(Предложение1, " ")
        vArr2 = Split(Предложение2, " ")

        For lngCnt1 = LBound(vArr1) To UBound(vArr1)
            s = vArr1(lngCnt1)
            sLen = Len(s)
If sLen > 0 Then
            pos = InStr(Предложение2 & " ", s & " ")

            For lngCnt2 = LBound(vArr2) To UBound(vArr2)

                If vArr2(lngCnt2) = s Then
                    xCell2.Characters(pos, sLen).Font.Color = vbRed
                    Exit For
                End If

            Next lngCnt2
End If
        Next lngCnt1

    Next

    Application.ScreenUpdating = True
End Sub

[/vba]

Такой вариант вроде норм:
[vba]

Код