Найти ячейку по содержанию слов

[vint]

Всё сделал !!! Сам ! (Приятно это осознавать)
всё элементарно
Выкладываю результат думаю многим пригодится, т.к. искал ответы на многих форумах подобные задачи никто не решил а потребность у людей есть.
Конешно грамотные люди скажут громоздко да и вообще странный принцип общета, может и не такой быстрый, однако он работает и хочу заметить безошибочно можно писать как хочешь (обратите внимание на последние 8 строк) то что надо, единственный минус регистр букв.Ну да ладно мож в будущем исправлю, пока времени нет разбираться наверняка одну строчку вписать в код.Можно при желании обновление экрана отключить - а мне нравиться смотреть как перебирает.
Всем спасибо !!!
Если кто предложит более грамотный код делающий тоже самое - неоткажусь.
Благодарю за участие!

[Aent]

Код: Выделить всё

Public Sub РазбрасывательСтрок()
    Dim r As Range
    Dim wsr As Worksheet
    Dim s As String
    Dim l As Long, ll As Long, i As Long, j As Long, k As Long, m As Long
    Application.ScreenUpdating = False
    'Сортируем имена допустимых листов по убыванию длины имени
    With ActiveWorkbook
          Set wsr = .Worksheets("Разное")
          ReDim ws(1 To .Worksheets.Count - 2) As Worksheet
          k = 0
          For i = 1 To .Worksheets.Count
              With .Worksheets(i)
                   If .Name <> "Общий" Then
                      .Range(.[A2], .[A2].SpecialCells(xlLastCell)).ClearContents
                  End If
              End With
              If InStr(1, "Общий|Разное", .Worksheets(i).Name, vbBinaryCompare) = 0 Then    'приемлемое имя листа
                   l = Len(.Worksheets(i).Name)
                   If k = 0 Then
                         ll = l
                   Else
                         ll = Len(ws(k).Name)
                   End If
                   If ll >= l Then
                        k = k + 1
                        Set ws(k) = .Worksheets(i)
                   Else
                         For j = k To 1 Step -1
                              If Len(ws(j).Name) < l Then
                                    Set ws(j + 1) = ws(j)
                              Else
                                    Set ws(j + 1) = .Worksheets(i)
                                    Exit For
                              End If
                          Next j
                          If j = 0 Then
                               Set ws(1) = .Worksheets(i)
                          End If
                          k = k + 1
                    End If
              End If
          Next i
    End With
    With Worksheets("Общий")
        For Each r In .Cells(2, 4).Resize(.Cells(.Rows.Count, 4).End(xlUp).Row - 1, 1)
            s = Trim$(r.Value)
            l = Len(s)
            For i = 1 To UBound(ws)
                s = Replace(s, ws(i).Name, vbNullString, 1, 1, vbBinaryCompare)
                If Len(s) < l Then    'Элемент присутствует
                    r.EntireRow.Copy _
                            ws(i).Rows(Application.WorksheetFunction.CountA(ws(i).Columns(3)) + 1)
                    l = Len(s)
                End If
            Next i
            s = Replace(s, ",", vbNullString)
            s = Replace(s, ";", vbNullString)
            s = Replace(s, " ", vbNullString)
            'добавьте сюда замену для других возможных разделителей
            If Len(s) > 0 Then    'присутствуют дополнительные имена
                r.EntireRow.Copy _
                        wsr.Rows(Application.WorksheetFunction.CountA(wsr.Columns(3)) + 1)
            End If
        Next r
    End With
    Application.ScreenUpdating = True
End Sub

Если нет желания различать регистр символов нужно использовать не бинарное а
текстовое сравнение
s = Replace(s, ws(i).Name, vbNullString, 1, 1, vbTextCompare)

[vint]

Уважаемый Aent, огромное спасибо !!!
То что надо. Интересный подход к использованию имен листов (правда это применимо только в моём случае).
Спасибо за подсказку бинарное-текстовое сравнение, всё-таки решил использовать на всякий случай vbTextCompare.
Да и ещё, такой вариант предварительной очистки листов не подойдет, т.к. столкнулся с такой проблемой, в случае если строк становиться меньше инфа удалена а выделение цветом остаётся (в оригинале используется автовыделение различным цветом согласно статусу), пока буду очищать как умею.
Также возник новый вопрос (если для этого надо создавать новую тему - скажите).
В оригинале в конце существует ещё лист "Диаграммы статистика", содержащий таблици и диаграммы статусов поимённых листов и общего (неважно). Дело в том что когда начал использовать РазбрасывательСтрок(свой код,Ваш не могу щас проверить -оригинал на работе) таблица содержащая ссылки на листы теряет связь =СЧЁТЕСЛИ('Маша'!#ССЫЛКА!;"просрочено"), а было =СЧЁТЕСЛИ('Маша'!D6 5000;"просрочено"), может это недостаток моего способа предварительного удаления строк?
Ещё раз большое спасибо за помощь, узнал много нового
P.S. Может кто нибудь поделиться ссылочкой на полный справочник по операторам VBA, а то в литературе описание только основных и руки остаються связанными приходиться задавать глупые вопросы и морочить людям головы.Буду благодарен.Спасибо

[Aent]

инфа удалена а выделение цветом остаётся

Вместо .ClearContents используйте просто .Clear - он стирает всё

Ссылки на книги можно найти здесь:
http://forum.developing.ru/showthread.php?t=11902
http://forum.developing.ru/showthread.php?t=14448
Наверно вам всё таки нужны не операторы а методы и свойства объектов Excel ...
Cамым полным источником является Микрософовский HELP по объектной модели Excel,
он ставится вместе с офисом (при установке поддержки VBA)
Впрочем, cами операторы VBA там (в справочной системе офиса) то же описаны.

[vint]

Да, да !!! именно Clear

Огромное спасибо за список литературы !!!