Профессиональные приемы работы в Microsoft Excel

Пожалуйста, войдите или зарегистрируйтесь.


Расширенный поиск  

Новости:

Новая редакция правил форума: 2.4. Если вопрос или ответ содержится во вложенном файле, все-равно кратко описывайте в сообщении вопрос или суть решения. Это необходимо, чтобы тему можно было найти через поиск.

Автор Тема: Поиск значений в столбце с указанием номеров строк, в которых они находятся  (Прочитано 253 раз)

0 Пользователей и 1 Гость просматривают эту тему.

lovko

  • Постоялец
  • ***
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 127

Здравствуйте! Прошу помочь с доработкой кода. Данный код ищет заданные слова в столбце, выделяет совпадения жирным и окрашивает красным. Вместо выделения совпадений, мне необходимо указывать номера строк, в которых они находятся. Перечень номеров строк необходимо вывести в Workbooks("7.0.xlsb").Sheets("Спер") в столбец А. Большое спасибо!

[/Sub Find_n_Highlight()
    On Error Resume Next: Err.Clear
    Dim ra As Range, cell As Range, res, txt$, v, pos&
    res = Workbooks("7.0.xlsb").Sheets("Сдан").Range("C2")
    If VarType(res) = vbBoolean Then Exit Sub    ' нажата кнопка ОТМЕНА
    txt$ = Trim(res): If Len(txt) = 0 Then Exit Sub    ' текст не введен, или состоит из пробелов

    Set ra = Workbooks("Сеть7.xlsb").Sheets("Срас").Range([P2], Range("P" & Rows.Count).End(xlUp))    ' диапазон для поиска
    Application.ScreenUpdating = False
    ra.Font.Color = 0: ra.Font.Bold = 0  ' сброс цветового выделения

    For Each cell In ra.Cells    ' перебираем все ячейки
        pos = 1
        If cell.Text Like "*" & txt & "*" Then
            arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
            If UBound(arr) > 0 Then    ' если подстрока найдена
                For Each v In arr    ' перебираем все вхождения
                    pos = pos + Len(v)    ' начальная позиция
                    With cell.Characters(pos, Len(txt))
                        .Font.ColorIndex = 3    ' выделяем цветом
                        .Font.Bold = True    ' и полужирным начертанием
                    End With
                    pos = pos + Len(txt)
                Next v
            End If
        End If
    Next cell
End Subcode]
Записан

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +32/-0
  • Оффлайн Оффлайн
  • Сообщений: 570
  • Доброта спасет мир...

Здравствуйте,
Sub Find_n_Highlight()

End Sub
    On Error Resume Next: Err.Clear
    Dim ra As Range, cell As Range, res, txt$, v, pos&
    res = Workbooks("7.0.xlsb").Sheets("Сдан").Range("C2")
    If VarType(res) = vbBoolean Then Exit Sub    ' нажата кнопка ОТМЕНА
    txt$ = Trim(res): If Len(txt) = 0 Then Exit Sub    ' текст не введен, или состоит из пробелов

    Set ra = Workbooks("Сеть7.xlsb").Sheets("Срас").Range([P2], Range("P" & Rows.Count).End(xlUp))    ' диапазон для поиска
    Application.ScreenUpdating = False
    ra.Font.Color = 0: ra.Font.Bold = 0  ' сброс цветового выделения

Dim i&: i = 1
   
    For Each cell In ra.Cells    ' перебираем все ячейки
        pos = 1
        If cell.Text Like "*" & txt & "*" Then
           
            Workbooks("7.0.xlsb").Sheets("Спер").Cells(i, 1).Value = cell.Row
            i = i + 1

'            arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
'            If UBound(arr) > 0 Then    ' если подстрока найдена
'                For Each v In arr    ' перебираем все вхождения
'                    pos = pos + Len(v)    ' начальная позиция
'                    With cell.Characters(pos, Len(txt))
'                        .Font.ColorIndex = 3    ' выделяем цветом
'                        .Font.Bold = True    ' и полужирным начертанием
'                    End With
'                    pos = pos + Len(txt)
'                Next v
'            End If
        End If
    Next cell
End
Записан
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра
 



Темы без ответов

05.03.2019 17:00 Последовательный вывод таблиц Excel в один документ Word без шаблона 422
05.03.2019 09:29 Нежелательные изменение размеров колонтитула при редактировании 292
07.02.2019 01:36 Как удалить дубликаты из выпадающего связанного списка? 412
20.01.2019 12:38 Все варианты частичного суммирования 545
13.01.2019 12:24 Заполнение диапазона числами - в виде кластеров 418
30.09.2018 10:24 Расчет процентов за определенный период (месяц) с учетом изменений и платежей 870
03.03.2018 00:00 Подсчет отработанного времени, за исключением заранее определенных перерывов 1657
14.02.2018 10:11 Подготовить читабельную отчетность по платежам 1693
23.01.2018 13:46 Найти вероятность повторной покупки 1523
12.01.2018 23:56 Сделать отчет на Power BI (Dashboard) 2146





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.088 секунд. Запросов: 94.