Всем доброго времени суток. Этот макрос является ответом на вопрос: "Как выделить искомое слово в ячейках? Именно слово, а не ячейку". Может кому-то пригодится.
Option Explicit
Private Sub CheckBox1_Click()
Call TextBox1_Change
End Sub
Private Sub TextBox1_Change()
Dim i As Long, lngMach As Long, lngMach2 As Long, vbComparison As Long, Cell As Range
If Len(Me.TextBox1) = 0 Then 'Пустой текстбокс
Me.LabelInfo.Caption = ""
Exit Sub
End If
If TypeName(Selection) <> "Range" Then 'НЕ диапазон выделен
Me.LabelInfo.Caption = "Selection is not a Range"
Exit Sub
End If
If Application.WorksheetFunction.CountA(Selection) = 0 Then 'Пустые ячейки
Me.LabelInfo.Caption = "Selection is empty"
Exit Sub
End If
If Me.CheckBox1 Then 'Учёт регистра
vbComparison = vbBinaryCompare
Else
vbComparison = vbTextCompare
End If
Application.ScreenUpdating = False
For Each Cell In Selection
'Мешаные цвета в ячейке обнуляем
If IsNull(Cell.Font.Color) Or Me.TextBox1.Text = "" Then
Cell.Font.Color = 0
End If
i = 1
lngMach = InStr(1, Cell.Text, Me.TextBox1.Text, vbComparison)
Do While InStr(i, Cell.Text, Me.TextBox1.Text, vbComparison) > 0 And i <= Len(Cell)
lngMach = InStr(i, Cell.Text, Me.TextBox1.Text, vbComparison)
Cell.Characters(lngMach, Len(Me.TextBox1.Text)).Font.Color = vbRed
i = lngMach + 1
lngMach2 = lngMach2 + 1
Loop
Next Cell
If lngMach2 = 0 Then
Me.LabelInfo = "No match"
Else
Me.LabelInfo = "Найдено совпадений: " & lngMach2
End If
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If TypeName(Selection) <> "Range" Then 'НЕ диапазон выделен
Me.LabelInfo.Caption = "Selection is not a Range"
Exit Sub
End If
If KeyCode = 8 And Shift = 2 Then
Selection.Font.Color = 0
End If
If KeyCode = 46 And Shift = 2 Then
Selection.Font.Color = 0
End If
If KeyCode = 46 And Len(Me.TextBox1.Text) = 1 Then
Selection.Font.Color = 0
End If
If KeyCode = 8 And Len(Me.TextBox1.Text) = 1 Then
Selection.Font.Color = 0
End If
End Sub
DANIKOLA, здравствуйте Было бы удобнее оценить код, если бы вы его прикрепили тут же (под спойлер, возможно) — чтобы не пришлось открывать файл…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
с одной стороны это выделит такое AAAAA если и ищем "AA" , но с другой стороны , нужно ли это? Может пропустить часть циклов
Код
i = lngMach + Len(Me.TextBox1.Text)
да и Len(Me.TextBox1.Text) впрочем как и все обращения к форме лучше наверно вынести за пределы циклов и присвоить переменным значения, ведь в процессе изменений не будет. далее, искать в Cell.Text не лучшая идея, я б наверно смотрел в сторону Cell.Formula. Ведь если там будет формула выдающая в качестве результата текст или формат диковенный, и в нем будет то что ищем , то будет сурприз.
Да, походу это лишняя строка. Сделал правки по Вашей подсказке БМВ.
Код
Код
Option Explicit
Private Sub CheckBox1_Click()
Call TextBox1_Change
End Sub
Private Sub TextBox1_Change()
Dim i As Long, lngMach As Long, lngMach2 As Long, vbComparison As Long, Cell As Range
If Len(Me.TextBox1) = 0 Then 'Пустой текстбокс
Me.LabelInfo.Caption = ""
Exit Sub
End If
If TypeName(Selection) <> "Range" Then 'НЕ диапазон выделен
Me.LabelInfo.Caption = "Selection is not a Range"
Exit Sub
End If
If Application.WorksheetFunction.CountA(Selection) = 0 Then 'Пустая ячейка
Me.LabelInfo.Caption = "Selection is empty"
Exit Sub
End If
If Me.CheckBox1 Then 'Учёт регистра
vbComparison = vbBinaryCompare
Else
vbComparison = vbTextCompare
End If
Application.ScreenUpdating = False
For Each Cell In Selection
'Мешаные цвета в ячейке обнуляем
'If IsNull(Cell.Font.Color) Or Me.TextBox1.Text = "" Then
Cell.Font.Color = 0
'End If
i = 1
'lngMach = InStr(1, Cell.Text, Me.TextBox1.Text, vbComparison)
Do While InStr(i, Cell.Text, Me.TextBox1.Text, vbComparison) > 0 And i <= Len(Cell)
lngMach = InStr(i, Cell.Text, Me.TextBox1.Text, vbComparison)
Cell.Characters(lngMach, Len(Me.TextBox1.Text)).Font.Color = vbRed
'i = lngMach + 1
i = lngMach + Len(Me.TextBox1.Text)
lngMach2 = lngMach2 + 1
Loop
Next Cell
If lngMach2 = 0 Then
Me.LabelInfo = "No match"
Selection.Font.Color = 0
Else
Me.LabelInfo = "Найдено совпадений: " & lngMach2
End If
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If TypeName(Selection) <> "Range" Then 'НЕ диапазон выделен
Me.LabelInfo.Caption = "Selection is not a Range"
Exit Sub
End If
If KeyCode = 8 And Shift = 2 Then
Selection.Font.Color = 0
End If
If KeyCode = 46 And Shift = 2 Then
Selection.Font.Color = 0
End If
If KeyCode = 46 And Len(Me.TextBox1.Text) = 1 Then
Selection.Font.Color = 0
End If
If KeyCode = 8 And Len(Me.TextBox1.Text) = 1 Then
Selection.Font.Color = 0
End If
End Sub
О, и с буквами АА..., тоже чуток поправил, не идеально конечно...