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

vint · 19 мар 2009, 17:23

Здраствуйте !
Помогите пожалуста составить код неделю мучаюсь

проблема такая
в первом "обшем" листе, строки в столбце D содержат различные перечисления, например : имен (Маша, Петя, Клава, Дима и т.д.)
причём варианты содержания как одного, двух так и нескольких сразу в любой последовательности.
есть ещё 4 листа Маша, Петя, Клава и последний Разное
Задача необходимо скопировать строки из общего листа в другие по критерию :если в яцейке присутствует слово Маша значит в лист Маша и далее, а если содержит любое другое неизвестное имя значит в Разное.
По какому критерию копировать в Маша, Петя, Клава не вопрос
'yacheika = Application.Range("D" & iRow).Value
'If Not InStr(1, yacheika, "Маша") Then
всё работает
а вот как если попалось неизвестное имя
Заранее благодарен! Я уже из сил выбился.

другими словами нужен код :
если в ячейке присутствует имя отличное от Маша, Петя, Клава тогда
'MsgBox "Эту строку надо копировать в лист Разное"

Naeel Maqsudov · 20 мар 2009, 00:27

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

Function GetSh(ByVal name As String) As Worksheet
On Error GoTo others
  Set GetSh = Application.ActiveWorkbook.Worksheets.Item(name)
  Exit Function
others:
  Set GetSh = Application.ActiveWorkbook.Worksheets.Item("Разное")
End Function

Sub qwe()
Dim row As Range, sh As Worksheet, R As Long
  For Each row In Application.ActiveWorkbook.Sheets("General").Cells(1, 1).CurrentRegion.Rows
    Set sh = GetSh(row.Range("D1").Value)
    row.Copy sh.Cells(Application.WorksheetFunction.Count(sh.Columns(1)) + 1, 1)
  Next
End Sub

vint · 20 мар 2009, 09:48

Большое спасибо за участие!
только я никак не могу понять как это прикрутить к своему файлу
дело в том что я только месяц как изучаю VBA - жизнь заставила
одну прогу в 30 печатных листов с успехом накатал все работает,
а вот с этой запнулся
если не трудно помогите пожалуста разжевать Ваш код
или влепить в мой прикрепленный фаил "Имена"
Заранеее благодарю за помощь!

Naeel Maqsudov · 20 мар 2009, 09:58

Хм... Вот с файла и надо было начинать.

&quot писал(а):перечисления, например : имен (Маша, Петя, Клава, Дима и т.д.)

Как-то было не очевидно, что там несколько имен в 1 ячейке....
Сейчас некогда, вечером посмотрю.

vint · 20 мар 2009, 10:34

Naeel Maqsudov писал(а):Хм... Вот с файла и надо было начинать.

Как-то было не очевидно, что там несколько имен в 1 ячейке....
Сейчас некогда, вечером посмотрю.

Да согласен косяк, надо было сразу файл кинуть !
хотя вроде писал
"варианты содержания как одного, двух так и нескольких сразу в любой последовательности"
ну да ладно
вобщем в файле видно как оно работает, неработает только лист "Разное"
Буду ждать Вашей помощи.
Еще раз благодарю за отзыв!
P.S. На самом деле "Имена" это облегченный вариант настоящего файла который содержит сотни строк и обрабатывается по многим критериям а в конце должен раскидываться по принадлежности. Код большой и все работает, а вот страницу Разное победить немогу.Разобравшись с этим файлом я смогу воткнуть его в настоящий.

vint · 20 мар 2009, 12:40

кстати вверху опечатка "Not" там как зайцу стоп-сигнал
просто когда писал голова дымилась от эксперементов
И ещё в моем примере после выполнения макроса остаётся выделенная строка от последнего копирования, если кому интересно убирается путё добавления в конец процедуры :
'снимаем выделение строки после копирования
'Application.CutCopyMode = False
С нетерпением жду помощи с листом "Разное"

Aent · 20 мар 2009, 13:32

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

Public Sub РазбрасывательСтрок()
     Dim r As Range
     Dim ws As Worksheet
     Dim s As String
     Dim l As Long
    
     Application.ScreenUpdating = False
     With Worksheets("Общий")
           For Each r In .Cells(2, 4).Resize(.Cells(.Rows.Count, 4).End(xlUp).Row - 1, 1)
                s = "," & Replace(r.Value, " ", vbNullString)
                l = Len(s)
                For Each ws In ActiveWorkbook.Worksheets
                     If Not (ws.Name = "Общий" Or ws.Name = "Разное") Then
                          s = Replace(s, "," & ws.Name, vbNullString)
                          If Len(s) < l Then    'Элемент присутствует
                               r.EntireRow.Copy _
                                    ws.Rows(Application.WorksheetFunction.CountA(ws.Columns(3)) + 1)
                               l = Len(s)
                          End If
                     End If
                Next ws
                s = Replace(s, ",", vbNullString)
                If Len(s) > 0 Then    'присутствуют дополнительные имена
                     Set ws = ActiveWorkbook.Worksheets("Разное")
                     r.EntireRow.Copy _
                          ws.Rows(Application.WorksheetFunction.CountA(ws.Columns(3)) + 1)
                End If
          Next r
     End With
     Application.ScreenUpdating = True
End Sub

vint · 21 мар 2009, 11:52

О ЧУДО ОНО РАБОТАЕТ !!!

нипойму как, но работает (эти операторы мне не известны)
главное коротко и быстро, единственное добавил в начало очистку листов а то при пересчете он добавляет а не обновляет.
Щас приду в себя от счастья, и начну разбираться как это работает !
Надо проверить в реальном файле, ведь там вовсе не Клавы и Пети а название основных подразделений предприятия а в разном что угодно, может фамилия а может какой нибудь отдел типа "БТМ" или "УГУ БО" да и еще человек который это заполняет может написать как угодно через запятую через пробел а то и сразу поэтому я и говорил что конкретно мне известно только основные названия "имена" а все что к этому не лепиться это к разному.
Большое Вам спасибо! Буду изучать код, разбирать по косточкам.

---------- Post added at 11:52 ---------- Previous post was Вчера at 15:19 ----------

Не подходит!

Стоит убрать запятую и результат ошибочный.
Код интересный, но в данном случае неприменим.
Уже не знаю как объяснить задачу.
Необходимо непосредственно в коде указать эталонные слова, в том числе пробел, запятую, точку. Далее в случае обнаружения в ячейке хоть одного символа (неважно буквы или цифры) несоответствующего эталону, то это то что надо. If содержит не эталон Then.
Повторюсь заставить человека работающего с этим документом заполнять согласно определенному правилу, не вариант к тому же документ используется давно и содержит сотни строк - никто переделывать не будет(в смысле поставить запятые и пробелы где надо или расположить слова в определенном порядке).
А моя задача внедрить туда дополнительный код который избавит от обезьяней работы (распределения строк по принадлежности).
Нужна помощь именно с листом разное.
Хелп!!!

Aent · 21 мар 2009, 12:52

Вы уж определитесь сразу с точной формулировкой вашей проблемы.
1) Могут ли имена листов перекрываться (В терминологии вашего примера Вася и Васятка или КОЛЯ и ОЛЯ ). Помещать в этом случае строку на оба листа или только на лист с длинейшим именем ?
2) Нужно ли учитывать регистр символов ? (Заглавные и строчные различаются ?)
3) Если пробел не является обязательным разделителем и у вас в книге есть листы
AAA,BBB и AAABBB куда помещать строку содержащую АААВВВ
4) В вашей реальной задаче для ключей используются кириллица и латиница вперемешку ?
Т.е ваш контрагент мог по ошибке набрать одинаково выглядящие символы не в ной раскладке a-а o-о e-е и т.д. Надо ли это распознавать? Макрос может привести строку к
одной раскладке ...

vint · 21 мар 2009, 14:11

1) Какойто разделитель всеравно должен присутствовать(если не поставят то сами виноваты), но сами эталонные имена на самом деле существуют с пробелом например "БУМ ЛО", "БУМ ТР", "БУМ УРА"(но они известны). Если попадётся "БУМ ЛО" значит в лист "БУМ ЛО". Если попадется все три "БУМ ЛО", "БУМ ТР", "БУМ УРА" значит соответственно во все три листа.А если "БУМ ЛО", "БУМ ТР", "БУМ УРА", "ОПА", значит во все три и "ОПА" мы видим впервые значит еще и в Разное.
2)На всякий случай нужно.
3)Конешно в АААВВВ
4)"ваш контрагент мог по ошибке набрать одинаково выглядящие символы"
наберет, значит сам виноват. Не учитывать, слишком жирно будет.
Извините Реальные имена и документ предоставить не могу(тайна производства-кто узнает мне кирдык)