Спасибо!  
 
Завтра, на свежую голову попробую, погоняю вдоволь, даже в строчку  
 
For Each cc In bd.[a1:a17]
 
попробую a17 заменить на "динамически, до последней заполненной строки"  
 
Еще раз, спасибо и спокойной ночи!:)

HUGO, спасибо за терпение вникать в проблемму!:)  
 
Пока прокручиваю с клавишей F8 без фрагмента:  
"Select Case param  
 Case "Down": str_ = "Application.Run ""MatrixMnP.xls!RANFJFJ02MnF"""  
 Case "Up": str_ = "Application.Run ""MatrixMnP.xls!RANFJFJ02MnFa"""  
 Case Else: str_ = ""  
 End Select  
 
 MsgBox cc.Value & " = start" & vbNewLine & cc.Offset(1).Value & " = end" & vbNewLine & str_".  
 
 С ним выдает сообщение:  
   
 Compile error:  
 Variable not defined  
 
 высвечивается: str_  
----------------------------------------------------------------------------------------------  
 Прокрутил несколько раз, срабатывает акуратно!  
 
 В уточнение нуждается только условие: "Down"/"Up", еще раз уточню  
 Когда начало диапазона совпадает с "Down" - то выборку делаем только со строчек совпадающими с "Up" и наоборот, например:  
 1. Диапазон 398-369 выборку делаем(конечно в ячейке F20 всегда ставим значение начало диапазона, в случае 398-1.8052)    
со строчками "Up":  
    393, 384, 377 и 369;  
 2. Диапазон 369-317 выборку делаем(конечно в ячейке F20 всегда ставим значение начало диапазона, в случае 369-2.4658)  
со строчками "Down":  
    359, 340, 330 и 317;  
 3. Диапазон 317-279 выборку делаем(конечно в ячейке F20 всегда ставим значение начало диапазона, в случае 317-1.0405)    
со строчками "Up":  
    307, 303, 290, 283 и 279;  
  и т.д.  
 И 14-й диапазон:  
    Диапазон 30-3 выборку делаем(конечно в ячейке F20 всегда ставим значение начало диапазона, в случае 30-1.3503)    
со строчками "Up":  
    23, 20, 8 и 3.

На всякии случай,  база данных с двумя листами.  
   
Спасибо nerv за подсказку, пока выдает ошибку:  
 
Run-time error '9':  
Subscript out of range

"Я всёж не вполне понял, что именно нужно сделать."  
Попробую еще раз объяснить.  
Лист Sheets("BD MN"), книги "BDa.xls" - это первый лист базы данных, она постоянно обновляется.  
В столбца  "А:А" этого листа даны последовательно, начиная с А1 начало и конец всех диапазонов(циклов).  
А1 - начало первого;  
А2 - конец первого = начало второго;  
А3 - конец трьетего = начало четвертого;  
А4 - котец четвертого = начало пятого ... и так до последней заполненой строчки столбца.  
Средствами VBA требуется определить эти диапазоны(или циклы - если так удобнее).  
Далее, переносимся в столбце  "F:F" Sheets("BD MN"), здесь уже эти  диапазоны(циклы) находятся в развернутом виде.  
Например Первый диапазон, который начался в А1 и имеет обозначение 398 заканчивается в А2 с обозначением 369 имеет в  "F:F" следующий вид:  
F2 - 398=А1  
F3 - 393  
F4 - 392  
F5 - 384  
F6 - 381  
F7 - 377  
F8 - 375  
F9 -.369=А2  
Выборка всех этих 8 ячеек и надо сделать в книге "MatrixMnP.xls", начиная с ячейки F20 - F2 - 398=А1 Down  1.8052  
                         F22 - F3 - 393       UP      2.0980  
                         F24 - F5 - 384       UP      2.3290  
                         F24 - F7 - 377       UP      2.3216  
                         F24 - F9 -.369=А2  UP     2.4658  
 После выборки запускаем макросы для анализа.  
 Потом начинаем поиск и выборки второго диапазона(цикла) и так до конца - до последней заполненой строки А:А, или в развернутом виде "F:F.  
Спокойной ночи!:)

Спасибо Hugo за ответ!  
 
Коряво, потому что рекордером делал, еще не подчищал.  
Но не смотря на это макрос акуратно все делает, если запустите через F8, сами убедитесь, но требуется "автоматическое" разпознавание диапазонов-циклов, а этого как раз в моего макроса и нет!  
Сейчас попробую, что вы посоветовали и отпишусь.

Тогда, вот еще раз:  
 
"Одно из решении вероятно будет - циклами.  
 Один цикл = один диапазон.  
 
1. Начало первого цикла = А1(Sheets("BD MN"))  
   Конец первого цикла = А2(Sheets("BD MN"))  
2. Начало второго цикла = А2(Sheets("BD MN"))  
   Конец второго цикла = А3(Sheets("BD MN"))...  
3...Дальше третий, четвертый и т.д. до последней заполненной строке в колонке F:F Sheets("BD MN").  
   Начало и конец циклов определяем в колонке А:А Sheets("BD MN"), а сами цыклы включая их начало и конец находятся в колонке F:F Sheets("BD MN").  
 "Цепочка" - от того, что циклый следуют непосредственно одним за другим.  
 "Связанных" от того, что конец преидущего=начало следующего.  
"Динамических" из-за того, что ячеек в циклах разные по количество и страница постоянно обновляется и цыклы увеличиваются и сдвигаются.  
 Надеюсь, что сейчас понятнее!:)

{quote}{login=nerv}{date=28.07.2011 02:29}{thema=}{post}[F20]= ExecuteExcel4Macro("'c:\files\[BDа.xls]BD MN'!R2C9")
 
c:\files\ - замените на путь к вашей книге{/post}{/quote}  
 
Заменил, в результате выскакивает окошко с предложением выбрать файл, после выбора файла стоимость ячейки I2 с листа "BD MN" книги "BDа" вставляется в ячейки "F20", книги "MatrixMnP.xls"  
 
Этот момент в моем макросе: SvyazBDasMatrix(он есть в примере) решил так:    
   Range("I2").Select     ' выбераем соответствующей стоимости  
   Selection.Copy          ' копируем ее  
   Windows("MatrixMnP.xls").Activate ' ставим ее в  
   Range("F20").Select                   ' ячейки  
   ActiveSheet.Paste                     ' F20 в книге "MatrixMn.xls"  
   Application.CutCopyMode = False  
   что, конечно не очень хорошее решение,  можно оптимизировать, но суть что оба варианта предполагают вручную определить границы диапазона и вручную перейти к следующему, а основная задача в:  
   "автоматизировать и сделать более универсальным(макроса), чтоб можно было его приложить и при добавлении на этой странице новые данные, и на других страницах, которые в примере не показал."  
   Данные, каждую минуту обновляются и диапазоны сдвигаются, появляются новые.  
   По этой причине думал, что цепочка "динамических" связанных циклов(если такое возможно!) решить проблемму с автоматизацией.  
   Как всегда, скорее всего плохо объяснил!:)

{quote}{login=nerv}{date=28.07.2011 12:53}{thema=}{post}объясните, что требуется "сделать" с данными книг{/post}{/quote}  
 
Стоимость ячейки I2 с листа "BD MN" книги "BDа" перенести в ячейки "F20", книги "MatrixMnP.xls"  
 Стоимость ячейки I3 с листа "BD MN" книги "BDа" перенести в ячейки "F22", книги "MatrixMnP.xls"  
 Стоимость ячейки I5 с листа "BD MN" книги "BDа" перенести в ячейки "F24", книги "MatrixMnP.xls"  
 Стоимость ячейки I7 с листа "BD MN" книги "BDа" перенести в ячейки "F24", книги "MatrixMnP.xls"  
 Стоимость ячейки I9 с листа "BD MN" книги "BDа" перенести в ячейки "F28", книги "MatrixMnP.xls"  
  Дальше запуск макросов блока анализа, т.к. это пример и книга MatrixMnP неполная, то и запуск макросов невозможен!  
   На этом работа с первого  диапазона закончена, приступаем ко второго диапазона.  
   Начало второго диапазона является конец первого.

Добрый день, всем!  
 
Макрос, которого желательно автоматизировать является связь между блоками "BDа.xls"-база данных и "MatrixMnP.xls"-блок анализа.  
Вручную, рекордером сделал(часть кода прилагаю), но макрос получился жестко привязанный к конкретной странице.  
Хотелос бы его автоматизировать и сделать более универсальным, чтоб можно было его приложить и при добавлении на этой странице новые данные, и на других страницах, которые в примере не показал.  
   
Вот примерная логика макроса:  
1. По значении ячейки с адрессом: А1(Sheets("BD MN")), определяющее начало Первого диапазона, найти совпадение в колонки F:F.  
 
2. По значении ячейки с адрессом: А2(Sheets("BD MN")), определяющее конец Первого диапазона, найти совпадение в колонки F:F.  
 
3. По условию Down[т.е. если начальная строка содержить Down для выборки берем только строки, которые содержать UP, и наоборот:
если начальная строка содержить UP для выборки берем только строки, которые содержать Down](с адрессом: В1(Sheets("BD MN"))), взяв за начало 2-й строки Sheets("BD MN") выбрать все значения отвечающим    
условии UP, до конца Первого диапазона с колонки I:I и расположить их  в книге "MatrixMnP.xls", начиная с ячейки "F20" и дальше вниз.  
   Эти значения всегда расположены через одну строчку.  
 
4. Диапазоны не одинаковые по количество членов!  
 
5. Сценарии анализа зависит от условия начало(начальная строка) диапазона - Down (применяем Application.Run "MatrixMnP.xls!RANFJFJ02MnF"  
                                                                                            Application.Run "MatrixMnP.xls!Statistika9listovMnF)  
                                                                      или - UP   (применяем Application.Run "MatrixMnP.xls!RANFJFJ02MnFа"  
                                                                                            Application.Run "MatrixMnP.xls!Statistika9listovMnFа".  
 
6. Обработка страницы, в случае Sheets("BD MN"), заканчивается когда достигаем в колонки F:F до 0 или 1,    
(скорее до последней заполненной строке).  
   
Одно из решении вероятно будет - циклами.  
Один цикл = один диапазон.  
 
1.Начало первого цикла = А1(Sheets("BD MN"))  
  Конец первого цикла  = А2(Sheets("BD MN"))  
 
  Начало второго цикла = А2(Sheets("BD MN"))  
  Конец второго цикла  = А3(Sheets("BD MN"))...  
  Получается цепочка из связанных циклов.  
   
2.Циклы работают в колонке F:F.  
  Циклы обрабатывают разное количество ячеек, иногда только 2(начальная и конечная).  
 
  Сам вопрос: как сделать эту "цепочку из связанных циклов"?

{quote}{login=Alex_ST}{date=06.06.2011 11:58}{thema=}{post}Для того, чтобы "кракозябры" не возникали при вашей работе, KukLP где-то нарыл следующий метод...{/post}{/quote}  
На 7-ке попробовал - все выполнил через Unlocker, но к сожалению при перезагрузке 7-ка сного вытащила откуда-то файлы c_1251.nls и c_1252.nls и  восстановила все как прежде, т.е. попытка не удалась!

Извиняюсь Hugo, пока отвечал не заметил вашего решения, попробую и так.

Re sva  
 
 Спасибо, все сработало замечательно!:)  
 
 Re RAN  
 
 Насчет приложить пример .xls помню, но в случае подумал, что в самого текста кода макроса все видно.  
 
 Темму можно считать закрытой.

Добрый день!  
 
На форуме нашел замечательный макрос, чуть переделал его:  
   
Sub ZamenyaetUkazannoeChisloNaSimvol()  
 
Range("E4:M18").Select  
Dim cur_range As Range  
With ActiveSheet  
Dim aa As Integer  
aa = "0" ' Заменяет найденное число на символ "*"  
Set cur_range = Selection  
cur_range.Activate  
For x = 1 To cur_range.Rows.Count  
For y = 1 To cur_range.Columns.Count  
If InStr(cur_range(x, y), aa) <> 0 Then cur_range(x, y).Value = "*"  
Next y  
Next x  
End With  
End Sub  
 
Но, макрос берет все числа в которых входит "0", например 40, а мне надо только "0" чтоб заменялась, наверное не до конца "модернизировал", оригинальный макрос был в теме:  
 
 http://www.planetaexcel.ru/forum.php?thread_id=16552&forumaction=newreplyquoted&post_id=128695&page_forum=lastpage&allnum_forum=11

Спасибо, сейчас все понятно!  
 
Завершен, надеюсь, последный этап разработки макроса, и главное "разборки" как и чем он работает.  
Сейчас осталось за малым, научиться мне его безошибочно применять в полевых условиях - когда диапазон разбросанный и  
        - когда компактный.  
 
В конечном итоге усилиями всех вас появился отличный "поисковик" превосходящий по обему родного Ексел'овского "Найти все", разширенный  - выборки в отдельных листах, пригодные для дальнейшей обработки.  
 
Спасибо всем, приниманшие участие в нелегком деле проходит сквоз леса "непонятно, что требуется"!:))

{quote}{login=profx11}{date=01.06.2011 11:38}{thema=RE RAN}{post}Уже пробую и изучаю!:){/post}{/quote}  
 
  В этом варианте, работает как часики! Спасибо вам большое за выделенное время и терпения разбираться в моих ошибках.    
 
  Спасибо еще за пространные комементарии, очень помогают в учебе!  
 
  Осталось одна строчка, точнее часть строчки, кода непонятая мною:  
 
lrr = IIf(.Cells(1, 1) = "", 1, .Cells(Rows.Count, "A").End(xlUp).Row + 1)  
 
IIf(.Cells(1, 1) = "", 1, - ? что тут делаем?  
 
.Cells(Rows.Count, "A").End(xlUp).Row + 1) ' последняя заполненая строка + 1

Уже пробую и изучаю!:)

Доброе утро, RAN - выслал.

После очистки с "cncn" выгрузилис все 25 листов, но уже поздно, глаза слипаются проверять вручную, завтра на свежую голову проверять буду.  
Спокойной ночи всем!

Эта строка    
.Range("A" & lrr).Resize(w, 2) = arr1 ' выгружаем на лист массив  
заработала после изменения в  
If Arr(q, 2) = aa Then ' если совпадает с искомым  
 
У меня тоже, но не до конца выгрузила.

Вариант Vibor2VariantA, тот которой должен заработать.  
 
Спокойной ночи, до завтра вечером!

{quote}{login=Hugo}{date=01.06.2011 12:13}{thema=}{post}Как-то я пропустил продолжение... Был в небольшом отпуске :)  
Файл скачал, давайте пароль - мыло внизу, добавьте недостающее.{/post}{/quote}  
 
Уже послал!

Добрый вечер, всем!  
 
  Прошу, предварительно, сильно не ругаться и не пинать(:)) - этот макрос будет основной, в постоянном пользовании у меня.  
 
  Помогите разобраться  с этой строчки макроса:  
 
.Range("A" & lrr).Resize(w, 2) = arr1 ' выгружаем лист на массив  
 
  Немножко припомню истории:  
  Создатель макроса RAN(за, что еще раз выражаю ему благодарность!), макрос находится в  post_229480.xls от 20.05.2011, 21:20, стр. 4 „Найти и заменить“, в этом макросе - FJFJ229480, конструкция    
 
    For j = 1 To 9  
       aa = Sheets("OOO").Cells(j, 5).Value    
    For i = 2 To 6    
...............................................................  
...............................................................  
         With Sheets(j + 6)  
               lrr = IIf(.Cells(1, 1) = "", 1, .Cells(Rows.Count, "A").End(xlUp).Row + 1)  
               .Range("A" & lrr).Resize(w, 2) = arr1    
 
работает без задоринки, но макрос был сделан на примере, а в реале было совсем другое(как всегда!:))!    
 
Как и указал RAN в посте от 24.05.2011, 09:34 сделал поправку:  
 
„With Sheets("OOO")  
arr11 = Array(.Range("E22").Value, .Range("E40").Value, .Range("E61").Value, .Range("E83").Value, .Range("E105").Value, .Range("E134").Value, .Range("E149").Value, .Range("E165").Value, .Range("E181").Value)  
End With“,    
 
но сразу появилась необходимость в: On Error Resume Next, иначе выскакивает ошибка:  
 
Run-time error '1004':  
Application-defined or object-defined error  
 
При которой высвечивается как раз:  
 
.Range("A" & lrr).Resize(w, 2) = arr1 ' выгружаем лист на массив  
 
Пока, так и работал, с On Error Resume Next, но пришлось дальше по ходу дела изменить:  
 
„With Sheets("OOO")  
arr11 = Array(.Range("E22").Value, .Range("E40").Value, .Range("E61").Value, .Range("E83").Value, .Range("E105").Value, .Range("E134").Value, .Range("E149").Value, .Range("E165").Value, .Range("E181").Value)  
End With“    
 
на  
 
„ With Sheets("S26Лист10")  
                  arr11 = Array(.Range("D4").Value, .Range("D5").Value, .Range("D6").Value, .Range("D7").Value, .Range("D8").Value, .Range("D9").Value, .Range("D10").Value, .Range("D11").Value, .Range("D12").Value, .Range("D13").Value, .Range("D14").Value, .Range("D15").Value, .Range("D16").Value, .Range("D17").Value, .Range("D18").Value)  
          End With  
   For j = 1 To 15“  
 
Вот, тут уже On Error Resume Next не помогает, потому что выборка не произходит вообще. А, если убрать  
On Error Resume Next, то выскакивает    
 
Run-time error '1004':  
Application-defined or object-defined error и на этом все останавливается.  
 
  На этот раз, во избежания недоразумении положил рабочий файл на внешнем файлообменнике, убрал „украшательство“ и оставил только данные.  
Т.к.  файл рабочий, то пароль скину кому понадобиться на мыло.  
 
Вот ссылка на файл(xls): http://depositfiles.com/files/wyhmo95j9

{quote}{login=Kuzmich}{date=26.05.2011 11:39}{thema=Re}{post}Range("A1:D" & Cells(1, 4).End(xlDown).row).Copy{/post}{/quote}  
 
Так, тоже сработало, спасибо за участие!  
 
Доброй ночи всем!

Сработало без задоринки!:)  
 
Вот окончательный вид макроса:  
Sub CSVXLSCOPY()  
     
     Workbooks.OpenText Filename:= _  
       "путь к файлу.csv", _  
       Origin:=866, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _  
       xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _  
       Comma:=False, Space:=False, Other:=True, FieldInfo:=Array(Array(1, 1), _  
       Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True  
   Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _  
       TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _  
       Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _  
       :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _  
       True  
   Columns("C:C").ColumnWidth = 15.38  
   Columns("D:D").NumberFormat = "0.0000"  
       Columns("D:D").Select  
       ActiveCell.FormulaR1C1 = "=ROUNDDOWN(C,4)"  
     
   ActiveWorkbook.SaveAs Filename:= _  
       "путь к файлу.xlsm", _  
       FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False  
     ActiveCell.End(xlDown).Select  
     Range("A1:D" & Cells(Rows.Count, 4).End(xlUp).Row).Copy  
      Windows("адресс книги.xlsm").Activate  
   ActiveWindow.WindowState = xlMaximized  
   ActiveSheet.Paste  
   Range("P1").Select  
End Sub  
 
 Темму можно считать закрытой.  
 Спасибо ikki, не смотря но усталость отловили мою ошибку!  
 
 Kuzmich, сейчас попробую и этот вариант.

{quote}{login=ikki}{date=26.05.2011 11:22}{thema=}{post}а так?  
Range("A1:D" & Cells(Rows.Count, 4).End(xlDown).row).Copy  
 
PS а что означают буквы fx в Вашем нике, если не секрет?{/post}{/quote}  
 
Выдало сообщение:  
Run-time error '9':  
Subscript out of range  
 
"а что означают буквы fx в Вашем нике" - на одном форуме попыталькя зарегиться под ником "pro11", но это имя было занято и предложи выбрать из списка.

Добрый вечер!:)  
   
 Задача этого макроса открыть файл типа .csv, преобразовать его в xlsm, потом скопировать диапазона:  
     "A1:D" - где в D последная занятая ячеяка увеличивает свой номер, т.е. столбец D - типа "динамический", если можно так выразиться.  
      Прочитав не мало страниц форума понравилось для этой цели:  
         
      Range("A1:D" & Cells(Rows.Count, 4).End(xlDown)).Copy  
         
      но, на этой строчке макрос затыкается и выдает ошибку:  
 
      Run-time error '1004':  
      Method 'Range' of object '.Global' failed.  
 
      Подскажите, как мне выти из этого положения?  
      Вот и сам макрос:  
         
Sub CSVXLSCOPY()  
     
     Workbooks.OpenText Filename:= _  
       "путь к файлу.csv", _  
       Origin:=866, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _  
       xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _  
       Comma:=False, Space:=False, Other:=True, FieldInfo:=Array(Array(1, 1), _  
       Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True  
   Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _  
       TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _  
       Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _  
       :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _  
       True  
   Columns("C:C").ColumnWidth = 15.38  
   Columns("D:D").NumberFormat = "0.0000"  
       Columns("D:D").Select  
       ActiveCell.FormulaR1C1 = "=ROUNDDOWN(C,4)"  
   ActiveWorkbook.SaveAs Filename:= _  
       "путь к файлу.xlsm", _  
       FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False  
     ActiveCell.End(xlDown).Select  
     Range("A1:D" & Cells(Rows.Count, 4).End(xlDown)).Copy  
   ActiveWindow.ScrollWorkbookTabs Position:=xlFirst  
   Sheets("Имя листа").Select  
   Range("P1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _  
       , SkipBlanks:=False, Transpose:=False  
   Range("P1").Select  
 
End Sub

{quote}{login=RAN}{date=24.05.2011 09:34}{thema=}{post}1. Оба макроса одинаково запускаются с любого места книги, а не только с кнопки.  
With Sheets("OOO")  
       arr11 = Array(.Range("E22").Value, .Range("E40").Value, .Range("E61").Value, .Range("E83").Value, .Range("E105").Value, .Range("E134").Value, .Range("E149").Value, .Range("E165").Value, .Range("E181").Value)  
   End With  
2. Если с арифметикой такие нелады, а калькулятор починить не удается, используйте On Error Resume Next. --:)){/post}{/quote}  
 
Добрый день!:)  
 
Спасибо, сейчас все в порядке, а про кнопочку я и забыл.  
Не перестает удивлять скорость - 625 строк выборки в 9-ти листов за 5 секунд!!!:)

Добрый вечер, всем!  
 
Вот, окончательный вид макроса RAN-а:  
   
Option Explicit  
Sub FJFJ02()  
   Dim sh As Worksheet  
   Dim Arr, arr1(), i&, j&, q&, w&, aa$, bb$, lr&, lrr&  
   Dim arr11  
          arr11 = Array(Range("E22").Value, Range("E40").Value, Range("E61").Value, Range("E83").Value, Range("E105").Value, Range("E134").Value, Range("E149").Value, Range("E165").Value, Range("E181").Value)  
   For j = 1 To 9  
       aa = arr11(j - 1)    
       For i = 2 To 16    
           With Sheets(i)  
               bb = Sheets(i).Name    
               lr = .Cells(Rows.Count, "N").End(xlUp).Row    
               Arr = Range(.Cells(1, "N"), .Cells(Rows.Count, "O").End(xlUp)).Value    
               ReDim arr1(1 To lr, 1 To 2)    
               w = 0 '    
               For q = 1 To UBound(Arr)    
                   If Arr(q, 1) = aa Then    
                       w = w + 1  
                       arr1(w, 1) = Arr(q, 1)    
                       arr1(w, 2) = Arr(q, 2)    
                   End If  
               Next q  
           End With  
           With Sheets(j + 16)    
               lrr = IIf(.Cells(1, 1) = "", 1, .Cells(Rows.Count, "A").End(xlUp).Row + 1)  
               On Error Resume Next  
               .Range("A" & lrr).Resize(w, 2) = arr1    
               .Columns("C").NumberFormat = "@"    
               .Columns("C").ColumnWidth = 10.8    
               .Columns("B").ColumnWidth = 55    
               .Columns("A").ColumnWidth = 7.2    
               .Range("C" & lrr).Resize(w, 1) = bb    
           End With  
       Next i  
   Next j  
   For i = 17 To 26    
       Next i  
   End Sub  
Sub cncn()  
Dim i&  
   For i = 17 To 26  
       With Sheets(i)  
           .Columns("A:C").Clear  
       End With  
   Next i  
End Sub  
 
Столко тестов сделал за эти дни, что уже со счета сбился, когда первый раз запустил в реале не поверил результатам - перебор и выгрузка в листах    
 - 259(выбранных) строк, в девяти листах - 4 секунды!!!  
 Напоминаю, что перебор и выборка делается с  158 085 ячеек.  
 
 Не смог только справиться с этого глюка, когда запустил перебор на все 15-ти листах, при запуска очестки "cncn" выскакивает:  
 Run-time error '9':  
 Subscript out of range  
 и указывает на строчку -  With Sheets(i)  
 
 И второе, заглавный лист "OOO" должен быть активный, чтоб макрос запустился.  
   
 Огромное спасибо RAN-у за проявленное терпение и ювелирную работу!!!  
   
 Спасибо Юрий М и Hugo за активное участие, еслиб я сразу обратил внимание на подсказки Hugo, что можно не только через имен ячеек решить задачу, то давно бы уже решили, еще с ним. Когда выключил выборка имен с макроса Hugo то скорость сразу упала меньше чем 9 секунд.  
 Еще раз ниский вам поклон ребята за отзывчивость!!!

{quote}{login=Юрий М}{date=21.05.2011 01:12}{thema=Re: Re: }{post}В этом месте будет:  
 For n = 2 To 6 'Перебираем листы со второго по шестого  
для 15 листов так  
For n = 2 To 15 'Перебираем листы со второго по петнатцатого  
= = =  
profx11, я больше ничего переделывать не буду: то, оказывается, у Вас на первом листе данные расположены в другом порядке, теперь количество листов другое... Нельзя так. Перечитайте Правила, в части файлов-примеров.{/post}{/quote}  
 
Конечно, облегченный вариант почти ничего общего не имеет с оригинала,  вам же оригинал послал, сегодня пробовал по разному его сокращать, но зависал макрос Hugo, ведь хотелось сравнить как все макросы будут срабатывать на одном и том-же  
примере по скорости. Но наместо этого получилась путаница.  
Извините!  
Завтра на свежую голову разберусь по тихонечко и запущу обе варианта ваш и на RAN.  
Отпишус, потом по результатам.  
Сейчас - спокойной ночи всем, и еще раз спасибо за выделенное время мне и положенный вами труд!-)

{quote}{login=RAN}{date=21.05.2011 12:56}{thema=Re: Re: }{post}{quote}{login=profx11}{date=21.05.2011 12:37}{thema=Re: }{post}{quote}{login=Юрий М}{date=21.05.2011 12:06}{thema=}{post}Проверьте.{/post}{/quote}  
В этом месте будет:  
   
For n = 2 To 6 'Перебираем листы со второго по шестого  
 
для 15 листов так  
 
For n = 2 To 15 'Перебираем листы со второго по петнатцатого{/post}{/quote}  
Лист("ООО") + 5 листов с данными = 6  
Лист("ООО") + 15 листов с данными = ?????  
Калькулятор сломался?  
И листы для вывода тоже подвинуть надо будет!:D{/post}{/quote}  
 
Не то,что сломался, а весь заспанный - сегодня уже 18-тый час как за компом!(-