Привет всем  
С "небольшим макросом" разобрался(спасибо всем, отдельное спасибо хХх)  
Теперь возникла необходимость переносить информацию из всех строчек соответствующих условию на другой лист.  
1. Макрос выполняется по нажатию кнопки  
2. если  в колонке "G" стоит "1" то эта строка копируется на лист2, и так до конца диапазона.  
3. При последующем нажатии кнопки вся информация на втором листе удаляется и опять вставляются все строки с первого листа на против которых в колонке "G" стоит "1"  
 
Всем спасибо за помощь

После возникнокновения "нестандартной ситуации" услышал от одного ... что ему неправильно прочитали инструктаж. Во избежании таковых ситуаций в дальнейшем решил проганять всех через екзамен, и использовать для этого простой экзаменатор(тестирование, сродни сдачи екзаменов на водительские права)  
Но перед тем как делать его, набрал сдесь в поиске(честно думал что вариантов будет очень много) и не увидел ничего.  
Вопрос в общем только в том, что может я плохо искал. Тогда направте пожалуйста в нужную тему. Если нет, то просто спасибо, сделать я такое смогу и сам.

Привет всем,  
 
нужна помощь в написании макроса(возможно можно и без него)  
 
В колонках "К" и "О" указана периодичность обслуживания  
Нужно сделать так чтобы в начале каждого периода в колонках "М" и "Q" напротив соответствующей строки проставлялась "1". Значение "1" активно пока не нажмеш соответствующую кнопку "Выполнено", после чего оно меняется на "0". в начале следующего периода значение опять становится "1".  
Периоды могут быть: ежедневно, раз в неделю, раз в месяц, раз в квартал, раз в пол года, раз в год.  
После того как нажали кнопку "Выполнено" заполняетсятся информация о выполненой работе на листе "Архив"(копируется информация с колонок "L" и "P"  
листа 1 в колонку "С" листа "Архив"). В колонке "В" при этом прставляется дата и время.  
 
 
Далее все активные задания будут формироваться в отдельный чек лист для проведения обслуживания, и данные будут (это для информации,сделаю сам)

Перешёл на 2007 офис и получил следующую проблему:  
при запуске макроса  
Public dt As Date, n1 As String, n2 As String  
 
 
Sub ComboBox_AfterUpdate()  
 
 
 
 
   dt = ActiveSheet.Range("b" & ActiveSheet.[b16] + 16)
   UserForm1.Show  
   'Call InsetrRows  
 
End Sub  
 
Sub InsetrRows()  
 
       Dim appExcel As Excel.Application  
       Dim shtExcel As Excel.Worksheet  
       Dim Rows As Long  
       Dim MyArray() As Variant  
       Dim i As Long, r As Long  
       Dim Counter As Integer  
       Dim CounterAll As Integer  
         
       Counter = 1  
       CounterAll = 1  
       n1 = "Âèá³ð äàííèõ ïî ë³í³¿ "  
       Rows = 2500  
   
       i = 1  
         
       'Set appExcel = CreateObject("Excel.Application.8")  
       Set appExcel = CreateObject("Excel.Application.11")  
         
' Âûáîð äëÿ ëèíèè 320--------------------------------------------------  
       appExcel.Workbooks.Open ThisWorkbook.Path & "\Line320.xls", UpdateLinks:=0  
       Set shtExcel = appExcel.Worksheets("Data")  
       n2 = "'Nagema 320'"  
       Counter = 1  
       i = 1  
       ReDim MyArray(1 To 9, 1 To 11)  
       ' UserForm1.Show  
       For r = 8 To Rows  
           If shtExcel.Cells(r, 1) = dt Then  
               MyArray(i, 1) = shtExcel.Cells(r, 2)  
               MyArray(i, 2) = shtExcel.Cells(r, 11)  
               MyArray(i, 3) = shtExcel.Cells(r, 9)  
               MyArray(i, 4) = shtExcel.Cells(r, 12)  
               MyArray(i, 5) = shtExcel.Cells(r, 13)  
               MyArray(i, 6) = shtExcel.Cells(r, 15)  
               MyArray(i, 7) = shtExcel.Cells(r, 16)  
               MyArray(i, 8) = shtExcel.Cells(r, 29)  
               MyArray(i, 9) = shtExcel.Cells(r, 30)  
               MyArray(i, 10) = shtExcel.Cells(r, 48)  
               MyArray(i, 11) = shtExcel.Cells(r, 49)  
               i = i + 1  
             
           End If  
       Counter = Counter + 1  
       CounterAll = CounterAll + 1  
       PctDone = Counter / (Rows - 8)  
       PctDoneAll = CounterAll / (10000)  
       Call UpdateProgress(PctDone, PctDoneAll)  
         
       Next r  
       appExcel.Workbooks("Line320.xls").Close SaveChanges:=False  
       Set appExcel = Nothing  
       Range(Cells(6, 8), Cells(14, 18)) = MyArray  
' Êîíåö äëÿ ëèíèè 320 --------------------------------------------------  
 
' Âûáîð äëÿ ëèíèè 850--------------------------------------------------  
       Set appExcel = CreateObject("Excel.Application.11")  
       appExcel.Workbooks.Open ThisWorkbook.Path & "\Line850.xls", UpdateLinks:=0  
       Set shtExcel = appExcel.Worksheets("Data")  
       n2 = "'Nagema 850'"  
       Counter = 1  
       i = 1  
       ReDim MyArray(1 To 9, 1 To 11)  
       For r = 8 To Rows  
           If shtExcel.Cells(r, 1) = dt Then  
              MyArray(i, 1) = shtExcel.Cells(r, 2)  
               MyArray(i, 2) = shtExcel.Cells(r, 11)  
               MyArray(i, 3) = shtExcel.Cells(r, 9)  
               MyArray(i, 4) = shtExcel.Cells(r, 12)  
               MyArray(i, 5) = shtExcel.Cells(r, 13)  
               MyArray(i, 6) = shtExcel.Cells(r, 15)  
               MyArray(i, 7) = shtExcel.Cells(r, 16)  
               MyArray(i, 8) = shtExcel.Cells(r, 29)  
               MyArray(i, 9) = shtExcel.Cells(r, 30)  
               MyArray(i, 10) = shtExcel.Cells(r, 48)  
               MyArray(i, 11) = shtExcel.Cells(r, 49)  
               i = i + 1  
           End If  
         
       Counter = Counter + 1  
       CounterAll = CounterAll + 1  
       PctDone = Counter / (Rows - 8)  
       PctDoneAll = CounterAll / (10000)  
       Call UpdateProgress(PctDone, PctDoneAll)  
         
       Next r  
         
       appExcel.Workbooks("Line850.xls").Close SaveChanges:=False  
       Set appExcel = Nothing  
       Range(Cells(15, 8), Cells(23, 18)) = MyArray  
' Êîíåö äëÿ ëèíèè 850 --------------------------------------------------  
 
' Âûáîð äëÿ ëèíèè 315--------------------------------------------------  
       Set appExcel = CreateObject("Excel.Application.11")  
       appExcel.Workbooks.Open ThisWorkbook.Path & "\Line315.xls", UpdateLinks:=0  
       Set shtExcel = appExcel.Worksheets("Data")  
       n2 = "'Nagema 315'"  
       Counter = 1  
       i = 1  
       ReDim MyArray(1 To 9, 1 To 11)  
       For r = 8 To Rows  
           If shtExcel.Cells(r, 1) = dt Then  
              MyArray(i, 1) = shtExcel.Cells(r, 2)  
               MyArray(i, 2) = shtExcel.Cells(r, 11)  
               MyArray(i, 3) = shtExcel.Cells(r, 9)  
               MyArray(i, 4) = shtExcel.Cells(r, 12)  
               MyArray(i, 5) = shtExcel.Cells(r, 13)  
               MyArray(i, 6) = shtExcel.Cells(r, 15)  
               MyArray(i, 7) = shtExcel.Cells(r, 16)  
               MyArray(i, 8) = shtExcel.Cells(r, 29)  
               MyArray(i, 9) = shtExcel.Cells(r, 30)  
               MyArray(i, 10) = shtExcel.Cells(r, 48)  
               MyArray(i, 11) = shtExcel.Cells(r, 49)  
               i = i + 1  
           End If  
         
       Counter = Counter + 1  
       CounterAll = CounterAll + 1  
       PctDone = Counter / (Rows - 8)  
       PctDoneAll = CounterAll / (10000)  
       Call UpdateProgress(PctDone, PctDoneAll)  
         
       Next r  
         
       appExcel.Workbooks("Line315.xls").Close SaveChanges:=False  
       Set appExcel = Nothing  
       Range(Cells(24, 8), Cells(32, 18)) = MyArray  
' Êîíåö äëÿ ëèíèè 315 --------------------------------------------------  
 
' Âûáîð äëÿ ëèíèè 317 --------------------------------------------------  
       Set appExcel = CreateObject("Excel.Application.11")  
       appExcel.Workbooks.Open ThisWorkbook.Path & "\Line317.xls", UpdateLinks:=0  
       Set shtExcel = appExcel.Worksheets("Data")  
       n2 = "'Nagema 317'"  
       Counter = 1  
       i = 1  
       ReDim MyArray(1 To 9, 1 To 11)  
       For r = 8 To Rows  
           If shtExcel.Cells(r, 1) = dt Then  
               MyArray(i, 1) = shtExcel.Cells(r, 2)  
               MyArray(i, 2) = shtExcel.Cells(r, 11)  
               MyArray(i, 3) = shtExcel.Cells(r, 9)  
               MyArray(i, 4) = shtExcel.Cells(r, 12)  
               MyArray(i, 5) = shtExcel.Cells(r, 13)  
               MyArray(i, 6) = shtExcel.Cells(r, 15)  
               MyArray(i, 7) = shtExcel.Cells(r, 16)  
               MyArray(i, 8) = shtExcel.Cells(r, 29)  
               MyArray(i, 9) = shtExcel.Cells(r, 30)  
               MyArray(i, 10) = shtExcel.Cells(r, 48)  
               MyArray(i, 11) = shtExcel.Cells(r, 49)  
               i = i + 1  
           End If  
         
       Counter = Counter + 1  
       CounterAll = CounterAll + 1  
       PctDone = Counter / (Rows - 8)  
       PctDoneAll = CounterAll / (10000)  
       Call UpdateProgress(PctDone, PctDoneAll)  
         
       Next r  
         
       appExcel.Workbooks("Line317.xls").Close SaveChanges:=False  
       Set appExcel = Nothing  
       Range(Cells(33, 8), Cells(41, 18)) = MyArray  
' Êîíåö äëÿ ëèíèè 317 --------------------------------------------------  
 
 
 
 
Unload UserForm1  
Windows("Short report1.xls").Activate  
End Sub  
Sub UpdateProgress(Pct, PctAll)  
   With UserForm1  
       .Label1.Caption = n1 + n2  
       .FrameProgress.Caption = Format(Pct, "0%")  
       .FrameAllProgress.Caption = Format(PctAll, "0%")  
       .LabelProgress.Width = Pct * (.FrameProgress.Width - 10)  
       .LabelAllProgress.Width = PctAll * (.FrameProgress.Width - 10)  
       .Repaint  
   End With  
End Sub  
Выдает ошибку "Activex component cant creat object" на строку:  
Set appExcel = CreateObject("Excel.Application.11")  
 
Хотелось-бы знать что поменялось и как даная проблема решается  
 
Спасибо

В файле на страничке "1" данные внесены через каждых десять строк, на страничке "2" они должны быть в том-же виде но без пробелов в 10 строк. Как скопировать(протянуть) формулы в ячейках страницы "2" чтобы значение следующей было +10.

Есть програмка для оценки работников. Но поменялись некоторые условия оценивания и с помощью функций теперь у меня решить не получается. Может кто поможет с макросом или подскажет как это сделать с помощью функций. Условие в примере.  
Благодарю!

Уважаемые форумчане,  
необходима ваша помощь в ускорении работы файлов.  
А именно есть програма оценки работы рабочих, состоящая из трёх типов  файлов:  
"Список" - файл со списком рабочих и их данными - не содержит формул\макросов\ссылок(такой файл один)  
"Оценка" - файл для внесения данных - содержит около 8000 активных строк, много ссылок, формул и  два небольших макроса для ведения ЛОГ - файла и проставления имени пользователя(такой один файл, но в нем на каждый месяц своя страница)  
"Июль" - файл для консолидации информации и выведения процента премиальных - содержит около 800 активных строк, много ссылок, формул и небольшой макрос для заморозки(и отмены даного действия) информации(такой файл есть на каждый месяц)  
 
Все хорошо работает но ужасно медлено  
-  "Июль"(и остальные 11) не откроется(повиснет при подтягивании ссылок) если не открыть предварительно "Оценка". Сначала вообще сделал все 12 месяцев в одном файле, но он тогда не открывается вообще.  
- "Оценка" работает\открывается очень медленно, к тому-же в нем одновременно могут работать около 5 человек(кстати размер заполненого файла  30-40Мб)    
 
Возможно кто-то поможет с макросом, дабы можно было работать с этими файлами и не выпивать несколько чашек кофе при открытии\сохранении ("Июль"+11месяцев и "Оценка")