Добрый день! Есть список с наименованием Товара - в столбце А наименование , которое использует Покупатель; в столбце В - наименование Поставщика. Товар поставщика = Товару покупателя, т.е. в А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
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]
Добрый день! Есть список с наименованием Товара - в столбце А наименование , которое использует Покупатель; в столбце В - наименование Поставщика. Товар поставщика = Товару покупателя, т.е. в А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
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
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] И то не все совпадения точно находит, кое что всё ещё пропускает, не видит. Посмотрим, может кто из Более Опытных подтянуться к вашей теме. Чем смог тем и помог. Удачи.
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
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] И то не все совпадения точно находит, кое что всё ещё пропускает, не видит. Посмотрим, может кто из Более Опытных подтянуться к вашей теме. Чем смог тем и помог. Удачи.MikeVol
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
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]
Код
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