И кстати если просто копирование занимает 10 мин. - код явно требует оптимизации.

Hugo  
 
Возможно ты прав вот код скажи где его можно улучшить, при всём при том что он создаёт в процессе 20 файликов  
 
Private Sub CommandButton5_Click()  
Dim z As Integer, i As Long, a As Integer, x(1) As String, Имя As String, новаяКнига As Workbook, n As Integer, c As Integer, y As Integer  
Dim v As Integer, b As Integer, k As Integer  
Application.DisplayAlerts = False  
Application.Calculation = xlCalculationManual  
Район(0) = "Адмиралтейский"  
Район(1) = "Василеостровский"  
Район(2) = "Всеволожский"  
Район(3) = "Выборгский"  
Район(4) = "Калининский"  
Район(5) = "Кировский"  
Район(6) = "Колпинский"  
Район(7) = "Красногвардейский"  
Район(8) = "Красносельский"  
Район(9) = "Крондштатский"  
Район(10) = "Курортный"  
Район(11) = "Московский"  
Район(12) = "Невский"  
Район(13) = "Павловский"  
Район(14) = "Петроградский"  
Район(15) = "Петродворцовый"  
Район(16) = "Приморский"  
Район(17) = "Пушкинский"  
Район(18) = "Фрунзенский"  
Район(19) = "Центральный"  
k = 1  
For n = 0 To 19  
Имя = "C:\Users\a.voloschuk\Desktop\Маркетинговые отчеты по рынку\" & Район(n) & " район, отчет.xls"  
Set новаяКнига = Workbooks.Open("C:\Users\a.voloschuk\Desktop\Маркетинговые отчеты по рынку\Маркетинговые отчеты по рынку\" & Район(n) & " район, отчет.xls")  
z = 2  
v = 2  
b = 2  
For i = 2 To 50000  
If Лист1.Cells(i, 6) = Район(n) Then  
   If Лист1.Cells(i, 5) = 1 Then  
       For a = 1 To 29  
           новаяКнига.Sheets(1).Cells(v, a) = Лист1.Cells(i, a)  
       Next a  
       v = v + 1  
   Else  
       If Лист1.Cells(i, 5) = 2 Then  
           For a = 1 To 29  
               новаяКнига.Sheets(2).Cells(b, a) = Лист1.Cells(i, a)  
           Next a  
           b = b + 1  
       Else  
           If Лист1.Cells(i, 5) = 3 Then  
               For a = 1 To 29  
                   новаяКнига.Sheets(3).Cells(z, a) = Лист1.Cells(i, a)  
               Next a  
               z = z + 1  
               End If  
               End If  
   End If  
End If  
Next i  
Windows(новаяКнига.Name).Activate  
ActiveWorkbook.SaveAs Filename:=Имя, FileFormat:=xlExcel8  
ActiveWorkbook.Close saveChanges:=True  
Next n  
Район(0) = ""  
Район(1) = ""  
Район(2) = ""  
Район(3) = ""  
Район(4) = ""  
Район(5) = ""  
Район(6) = ""  
Район(7) = ""  
Район(8) = ""  
Район(9) = ""  
Район(10) = ""  
Район(11) = ""  
Район(12) = ""  
Район(13) = ""  
Район(14) = ""  
Район(15) = ""  
Район(16) = ""  
Район(17) = ""  
Район(18) = ""  
Район(19) = ""  
Label13.Caption = "Игого"  
MsgBox ("Игого го го")  
Application.DisplayAlerts = True  
Application.Calculation = xlCalculationAutomatic  
End Sub  
 
Часть где заполяется массив районов а потом удаляется нужна так как на форме несколько кнопок и если я не закрываю форму явно то значения не обнуляются , что неприемлемо. Если действительно можно улучшить прошу коменты.

Точнее даже очистку массива Район делается еще проще:  
Erase Район

А вот задать массив Район можно еще так:  
 
Район=Array("Адмиралтейский","Василеостровский","Всеволожский","Выборгский", _  
"Калининский","Кировский","Колпинский","Красногвардейский", _  
"Красносельский","Крондштатский","Курортный","Московский", _  
"Невский","Павловский","Петроградский","Петродворцовый", _  
"Приморский","Пушкинский","Фрунзенский","Центральный")

{quote}{login=Hugo}{date=13.09.2010 02:40}{thema=}{post}Там выше был не я :)  
{/post}{/quote}  
 
Подтверждаю. Это мои экзерсисы :О)

Ну и еще:  
Почему не через find(), а перебор каждой ячейки?  
Почему нельзя явно присвоить значения диапазону ячеек?  
новаяКнига.Sheets(1).range(Cells(v, 1),cells(v,29)) = Лист1.range(Cells(i, 1),cells(i,29))  
Это тоже прибавит скорости в обработке.    
ЗЫ, пока массивы раскрутишь правильно, они ведь сами по себе и сразу не понятно.  
Хотя, диапазон в массив, массив прокрутить и при совпадении условий сформировать новый и потом сразу выгрузить на лист...  
Игорь67

{quote}{login=The_Prist}{date=13.09.2010 03:52}{thema=}{post}В общем у меня получилось бы нечто такое:  
 
Private Sub CommandButton5_Click()  
   Dim i As Long, a As Integer, Имя As String, новаяКнига As Workbook, n As Integer  
   Dim z As Integer, v As Integer, b As Integer  
   Application.DisplayAlerts = False  
   Application.Calculation = xlManual  
   Application.ScreenUpdating = False  
   Район = Array("Адмиралтейский", "Василеостровский", "Всеволожский", "Выборгский", _  
                 "Калининский", "Кировский", "Колпинский", "Красногвардейский", _  
                 "Красносельский", "Крондштатский", "Курортный", "Московский", _  
                 "Невский", "Павловский", "Петроградский", "Петродворцовый", _  
                 "Приморский", "Пушкинский", "Фрунзенский", "Центральный")  
 
   For n = 0 To 19  
       Имя = "C:\Users\a.voloschuk\Desktop\Маркетинговые отчеты по рынку\" & Район(n) & " район, отчет.xls"  
       Set новаяКнига = Workbooks.Open(Имя)  
       z = 2: v = 2: b = 2  
       For i = 2 To 50000  
           Dim lVal As Long, vCellVal  
           For a = 1 To 29  
               vCellVal = Лист1.Cells(i, 5).Value  
               If ЛvCellVal = 1 Then  
                   lVal = v: v = v + 1  
               ElseIf vCellVal = 2 Then  
                   lVal = v: b = b + 1  
               ElseIf vCellVal = 3 Then  
                   lVal = z: z = z + 1  
               End If  
               новаяКнига.Sheets(3).Cells(lVal, a) = Лист1.Cells(i, a)  
           Next a  
       Next i  
       новаяКнига.SaveAs Filename:=Имя, FileFormat:=xlExcel8  
       ActiveWorkbook.Close True    'Хотя можно и False, т.к. это только что сохраненная книга  
   Next n  
   Label13.Caption = "Игого"  
   MsgBox ("Игого го го")  
   Application.DisplayAlerts = True  
   Application.Calculation = xlAutomatic  
   Application.ScreenUpdating = True  
End Sub{/post}{/quote}  
 
Круто))) всё таки чем  больше изучаю тем больше понимаю что нифига не знаю))))) но а если по существу то этот код работать не будет я же недаром написал  
 
For i = 2 To 50000  
If Лист1.Cells(i, 6) = Район(n) Then  
If Лист1.Cells(i, 5) = 1 Then  
For a = 1 To 29  
новаяКнига.Sheets(1).Cells(v, a) = Лист1.Cells(i, a)  
Next a  
v = v + 1  
Else  
If Лист1.Cells(i, 5) = 2 Then  
For a = 1 To 29  
новаяКнига.Sheets(2).Cells(b, a) = Лист1.Cells(i, a)  
Next a  
b = b + 1  
Else  
If Лист1.Cells(i, 5) = 3 Then  
For a = 1 To 29  
новаяКнига.Sheets(3).Cells(z, a) = Лист1.Cells(i, a)  
Next a  
z = z + 1  
End If  
End If  
End If  
End If  
Next i  
 
у меня данные распределяются по трём листам в зависимости от двух выполненых условий. Насчёт elseif согласен, просто ступил)))) Насчёт переборки массива, я подозреваю что лучше, но познания массивов очень маленькие так что не стал заморачиваться.    
 
{quote}Почему не через find(), а перебор каждой ячейки?  
Почему нельзя явно присвоить значения диапазону ячеек?  
новаяКнига.Sheets(1).range(Cells(v, 1),cells(v,29)) = Лист1.range(Cells(i, 1),cells(i,29)){/quote}  
 
просто не знал что так можно, думал что только с активными ячейками прокатывает.  
 
Переменную "имя" использовать нельзя, так как файлы совсем в другую дирректорию сохраняются если вы не заметили.  
 
цикл до 50000 используется для запаса вы правы это плохое решение, их там 40000  
да действительно было бы уместно Do while loop или что то вроде    
 
if Val(лист1.cells(i,1))=0 then i = 50000  
 
Насчёт select case Вроде как медленнее работает чем If? Чисто из за этого If и использую.  
 
насчёт этого    
 
For i=Lbound(Район) to Ubound (Район) 'т.е. для значений i от наименьшего значения индекса в массиве до наибольшего значения индекса в массиве  
Район(i)=""  
Next i  
 
всегда думал что явное указание быстрее чем цикл, поэтому не делал. Да и к тому же делается это один раз так что мне проще было тупо копирнуть кусок кода сверху))))  
 
А вообще спасибо, жду дискуссию далее так как некоторые моменты не ясны, например массивы Hugo ))))))

{quote}{login=Казанский}{date=13.09.2010 04:18}{thema=РусНекромант}{post}> А вообще спасибо, жду дискуссию далее  
 
А мы ждем пример с куском данных!  
Кстати, у Вас данные пишутся в существующие файлы. Может, сначала надо почистить данные, которые в них есть?  
Данные пишутся со 2-й строки. В первой строке, наверно, заголовок, причем такой же, как и исходном файле? Может, проще создавать файлы заново, копируя заголовок из исходного файла?{/post}{/quote}  
 
Да отчасти вы правы, но там идёт строки просто, три листа а с 29 колонки идут формулы и графики. Эти файлы дать не могу, сами по себе они пустые поэтому кстати и берутся из одной папки и сохраняются в другую, дать не могу так как не мои наработки может обидеться.  
Файл из которого берётся примерный, прикрепил.(ток без кода)

Попробуйте. Впишите правильные пути в константы.  
 
Option Explicit  
'"C:\Users\a.voloschuk\Desktop\Маркетинговые отчеты по рынку\"  
Const SRC_PATH As String = "c:\temp\in\"  
Const DST_PATH As String = "c:\temp\out\"  
Const NAME_END As String = " район, отчет.xls"  
 
 
Sub CommandButton5_Click()()  
Dim iFirstRow As Long, i As Long, wb As Workbook  
 
With ActiveSheet.Sort  
   .SortFields.Clear  
   .SortFields.Add Key:=Range("F2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal  
   .SortFields.Add Key:=Range("E2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal  
   .SetRange Range("A1").CurrentRegion  
   .Header = xlYes  
   .MatchCase = False  
   .Orientation = xlTopToBottom  
   .SortMethod = xlPinYin  
   .Apply  
End With  
 
Application.DisplayAlerts = False  
Application.ScreenUpdating = False  
With ActiveSheet  
   iFirstRow = 2  
   i = iFirstRow  
   Do  
       Do  
           i = i + 1  
       Loop Until .Cells(i, 5) <> .Cells(iFirstRow, 5) Or .Cells(i, 6) <> .Cells(iFirstRow, 6)  
       If .Cells(iFirstRow, 6) <> .Cells(iFirstRow - 1, 6) Or .Cells(i, 6) = "" Then  'новый район или конец  
           If Not wb Is Nothing Then  
               wb.SaveAs DST_PATH & wb.Name, FileFormat:=xlExcel8  
               wb.Close False  
           End If  
           If .Cells(i, 6) = "" Then Exit Do  'конец списка  
           Set wb = Workbooks.Open(SRC_PATH & .Cells(i - 1, 6) & NAME_END, ReadOnly:=True)  
       End If  
       Range(.Rows(iFirstRow), .Rows(i - 1)).Copy wb.Sheets(.Cells(i - 1, 5)).Range("A2")  
       iFirstRow = i  
   Loop  
     
End With  
Application.DisplayAlerts = True  
Application.ScreenUpdating = True  
 
End Sub

Проверяйте. Взял post_154790.xls и вставил туда код от 13.09.2010, 13:55 .  
Заменил только перебор листов на перебор массивов, ну и отключил обновление экрана. Ещё там изменил пути (проверял работу) - замените назад на свои, ну и название макроса поставьте своё, я сделал, чтоб по Alt+F8 можно было запускать.  
У меня на 2753 строках пробежал за 14 секунд, причём по ощущению, основное время занимает открытие и сохранение файлов.

Итак попробовал новый код и сравнил со своим, мой код на моей машине работает за 100,76 код Hugo работает за 57,28 что заметно быстрее. Спасибо за обучение постараюсь извлечь урок))))  
 
З.Ы. Обрабатывалось 22000 строк

РусНекромант, мы и так знаем, что наш Hugo летчик. Раз уж Вы сравнивали.:-)  
Игорь, Респект! Кто бы сомневался.  
 
57337

Леш, да ладно вам. Я искренне порадовался результату Игоря.  
Не, ну черт побери, порадуюсь и твоему! И так, на старт. Только нужно вынудить автора более-менее пример из жизни кинуть(чтоб не на пустых). Не, Игорь, Леш, раз уж зажгли... Вот же черти!

Восхитительно)))) Взял код Казанского, тестил на тех же условиях что и Hugo и свой код. И о чудо)))) всего 35,73)))))))) Но так как написано для меня непривычно поэтому пока что смутно представляю как работает. Ну я понимаю что я плохой программер потому что я использую кириллицу в названиях переменных, но не могу ничего с собой поделать)))) Поэтому мне сложно воспринимать код в котором переменные на английском. Просто когда переменные на русском то сразу видно что перед тобой переменная или функция а то бывает не понятно толи это переменную назвали допустим aaArr толи это спец константа)))))))(Я знаю что это массив)