То что нужно  
Спасибо!!!

Если сегодня не помогут, завтра выложу сюда  макрос(он на работе, а я нет :)

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

Всем привет  
 
Не получается у меня запустить макрос в цикл.  
А именно, в связи с тем что у меня около 500 строк присваивать каждой макрос и отдельную кнопку не получится.  
Нужна помощь в в следующем(файл post_90851.xls от x_X_x)  
Sub vipolneno1()  
   Application.ScreenUpdating = False  
   If Sheets("IS").[M1].Value > Sheets("IS").[A1].Value Then MsgBox "PAHO": Exit Sub
 
 
   Sheets("DB").Range("F4").Copy  
   Sheets("IS").Range("M1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False  
Эти строчки(две строки в вверху)сейчас выполняют копирование из определенного места и вставляют это значение тоже в определенную ячейку.  
 
Нужно чтобы копирование происходило не из F4, а из F3 - F6 в зависимости от условия( если в условии обслуживания, например в ячейке К1 страницы IS, стоит "ежемесячно" то копирование происходит из ячейки  F4 страницы DB, если стоит "ежеквартально" то копирование происходит из ячейки  F5 страницы DB, и.т.д.). Соответственно и вставлятся значение должно в зависимости от того-же условия. Тоесть это условие выполняется сразу для всего диапазона, и управляется одной кнопкой "Выполнено"  
 
 
   Sheets("IS").Range("A1:F1,L1").Copy  
   Sheets("archive").Select  
   Range("A1").Select  
   Selection.End(xlDown).Select  
   ActiveCell.Offset(0, 0).Range("A2").Select  
   Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False  
   Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False  
   Application.CutCopyMode = False  
   Range("A2").Activate  
   Sheets("IS").Select  
   Range("B1").Activate  
   MsgBox (ok)  
End Sub  
 
Спасибо!!

Можна так

Вот теперь и я понял.  
Я думаю решение от Dophin подходит полностью?

{quote}{login=The_Prist}{date=16.01.2010 12:49}{thema=}{post}Вариант такого опросника действительно выкладывался в свое время на форуме, но тема канула в Лету после атаки хакеров....  
Вот похожая тема.    
http://www.planetaexcel.ru/forum.php?thread_id=10639  
 
Может подойдет...{/post}{/quote}  
 
Конечно подойдет  
Спасибо!

{quote}{login=Dophin}{date=16.01.2010 12:48}{thema=}{post}http://www.planetaexcel.ru/forum.php?thread_id=9414  
 
не это?{/post}{/quote}  
Точно!  
Спасибо!

{quote}{login=Тиго}{date=16.01.2010 12:44}{thema=}{post}Нет Вы не правильно поняли или я не полно выложил мой вопрос. Нужно чтоб по коду высвечивалась вся страница красным цветом , как Вы мне пример выслали (в предыдущем письме) только там работала одна страница а мне нужно чтоб работала вся таблица, тоесть при вводе кода высвечивается вся страница{/post}{/quote}  
 
А можно пояснение сделать в файле, типа: если А1=В2 то диапазон С2:С4 становится красным

{quote}{login=faeton}{date=16.01.2010 12:25}{thema=}{post}смотрите на листе модуль    
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)  
 
я это с форума брал.    
вот похожая тема  
http://www.planetaexcel.ru/tip.php?aid=36  
 
X = Split(ActiveCell.Address(), "$") '***  
Rng = "b" & X(2) & ":" & "m" & X(2) '*** X(2)-номер строки    
' Rng -диапазон раскрашиваемых столбцов в строке X(2)  
Range(Rng).Interior.ColorIndex = 34 '*** раскрашиваем диапазон Rng  
 
Target.Font.Name = "Marlett" ' устанавливаем шрифт чтобы "a" отображалось как галочка.{/post}{/quote}  
 
Посмотрел, но получается что диапазон выделяется  только при нажатии а не автоматически при начале периода? или опять я недопонял?  
Спасибо!

The_Prist,  
 
Есть набор вопросов с вариантами ответов из которых правильный один.  
При запуске случайным образом формируется екзамен из скажем 10-ти вопросов.    
Сдающий выбирает правильные ответы, а програма считает сколько из десяти было "угадано". Если правильно скажем 8 то екзамен здал, если меньше то нет.  
 
Юрий М,  
 
это в принципе и нужно, буду еще искать  
 
Спасибо

Лови с выделением всей таблицы.  
ЗЫ.: Надеюсь я правильно понял задание?

Выделяется вся строка  
Сейчас сделаю на всю страницу

{quote}{login=Тиго}{date=16.01.2010 12:13}{thema=Условное форматирование}{post}Добрый день Всем. Подскажите пожалуйста есть таблица и по коду в ячейке А35 в столбце А высвечивается ячейка красным цветом. Вопрос: как сделать чтоб высвечивалась вся страница диапазона таблицы.{/post}{/quote}  
Тоесть если выполняется условие А8=А35(в твоем файле это есть условие форматирования)то вся таблица(А6:N30) становилась красной?

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

Привет всем,  
сегодня хоть и не пятница, но для меня день рабочий.  Учитывая то что все те кто ежеминутно чего-то от меня хотят сегодня отдыхает можна позволить себе посидеть на лучшем познавательном сайте(ИМХО).  
 
Аватар я воспринимаю как небольшой показатель статуса, поэтому для себя решил что еще не дорос.  
А ник получился как наверное у многих случайно. Еще во времена когда интернет был только у приближенных к богу и в дорогих интернетклубах возникла острая необходимость написать мейл. Пришел в один из таких клубов, начал регистрироваться, когда спросило ник в голову ничего не пришло, посмотрел по сторонам и увидел какой-то плакат(уже и не помню какой)на котором было написано Dark Angel. Подумав что не такой уж я и темный набрал Angel  и получил ответ что такой ник уже зарегестрирован. Учитывая что время поджимало и то что ник я себе потом могу сделать любой другой я просто два раза нажал на клавиатуру неглядя и получилось angelrr. А так как нету ничего постоянней чем временное пользуюсь этим ником до сих пор.

Привет всем,  
вопрос к faeton  
 
Я не смог понять в твоем решении каким образом активируется строчка(в даном случае подсвечивается голубым)в начале каждого периода.  
 
Если не сложно, то действительно было-бы удобно чтобы: в начале периода подсвечиваются соответствующие строчки, далее проходя по списку снимаем выделение(дабл клик), по завершению всего списка нажимаеш "выполнено" и все строки с которых снималось выделение копируются в архив. Далее цикл повторяется и при совпадении текущей даты с началом цикла автоматически подсвечиваются соответсвующие строки.  
 
Спасибо

{quote}{login=x_X_x}{date=14.01.2010 05:14}{thema=Re: }{post}{quote}{login=angelrr}{date=14.01.2010 03:52}{thema=}{post}Привет Всем еще раз и огромное спасибо за помощь  
x_X_x, очень доступно и понятно, отпишусь как все проверю.  
По ходу вопрос по даному макросу: таких блоков будет порядка 500шт, они будут статичны, так что можно просто сделать грубо говоря 500 блоков макроса. И сдесь вопрос: каково будет быстродействие?  
 
faeton, еще разбираюсь с вашим вариантом, для меня он сложнее в понимании, но всеравно спасибо.{/post}{/quote}  
 
1. Пожалуйста, работаю с "детьми" и по-этому приходится доступно излагать по привычке.  
2. Я полагал что это всего лишь пример и на самом деле строк может быть гораааздо больше, как реализовать на практике пока не знаю (я не волшебник, а только учусь) скорее всего надо совместить метод "faeton" t.e. отметить нужные строки, а потом перекинуть все записи "оптом". Большое кол-во макросов значительно утяжелит книгу + записи идущие в архив. Подумайте, может смысл есть перекидывать их в отдельную книгу.{/post}{/quote}  
 
Архив на самом деле и будет в другом файле(переделать макрос под это я смогу и сам), просто сдесь я упростил пример.  
По поводу совмещения хорошая идея, буду думать.

Привет Всем еще раз и огромное спасибо за помощь  
x_X_x, очень доступно и понятно, отпишусь как все проверю.  
По ходу вопрос по даному макросу: таких блоков будет порядка 500шт, они будут статичны, так что можно просто сделать грубо говоря 500 блоков макроса. И сдесь вопрос: каково будет быстродействие?  
 
faeton, еще разбираюсь с вашим вариантом, для меня он сложнее в понимании, но всеравно спасибо.

{quote}{login=angelrr}{date=14.01.2010 11:11}{thema=}{post}Вопрос к x_X_x  
при изменении даты =TODAY()например на 7дней ячейка с еженедельным обслуживанием не становится активной. Нужно чтобы она становилась активной каждый 7-й день при еженедельном , каждый 30-й при ежемесячном ...  
Или я что-то не понял  
Спасибо{/post}{/quote}  
 
Тоесть, например для еженедельно должно быть :  
ЕСЛИ Range("M2") = понедельник(каждый 7-йдень) ТО L2 становится активной(подсвечивается красным). Условие должно выполнятся при смене значения функции TODAY()  
 
Спасибо

Вопрос к x_X_x  
при изменении даты =TODAY()например на 7дней ячейка с еженедельным обслуживанием не становится активной. Нужно чтобы она становилась активной каждый 7-й день при еженедельном , каждый 30-й при ежемесячном ...  
Или я что-то не понял  
Спасибо

Ребята,  
 
большое спасибо, отпишусь когда разберусь с логикой макроса

{quote}{login=}{date=13.01.2010 10:03}{thema=Re: }{post}{quote}{login=}{date=13.01.2010 09:33}{thema=}{post}а кто будет отслеживать начало нового периода?{/post}{/quote}  
 
Начало периода должно определяться автоматически(если раз в неделю то каждый понедельник, если раз в месяц то каждое 1-е число....). Тоесть начался период и вместо "0" становится "1"(выполняется условное форматирование и задание которому соответсвуе "1" подсвечивается).  
 
Каждое утро человек открывает чек-лист и видит что ему нужно сделать. После выполнения каждого пункта задания он нажимает кнопку "Выполнено" и информация о проделаной работе накапливается в базе данных. База данных ведется для того чтобы можна было посмотреть историю обслуживания узла\оборудования за любой период(аналогично сервисной книге на автомобиль).  
Хотя я и понимаю, что зачастую вместо обслуживания будет просто нажиматься "Выполнено".{/post}{/quote}  
Это был я

Уважаемые форумчане,  
в моей задаче много работы или она не интересна?  
Меня устроит просто подсказка по решению, кое-что я могу и сам.  
Или, смотря на сколько популярна комерческая тема, тоже могу предложить теже 100р за решение(метод оплаты должен учитывать то что я из Украины и електронного кошелька у меня нет)

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

Спасибо

{quote}{login=The_Prist}{date=19.11.2009 10:17}{thema=}{post}Предположу, что проблема макроса в ошибке, а ошибка на этой строке:  
Set appExcel = CreateObject("Excel.Application.11")  
 
Но, angelrr, Вы не думаете, что ошибку должны описываать Вы, а не мы? Нам не видно что у Вас за проблема с этим макросом - ошибка или что-то не так отрабатывается. Пояснять надо, а не тупо код макроса выкладывать.{/post}{/quote}  
 
Я описал ощибку  
 
"Выдает ошибку "Activex component cant creat object" на строку:  
Set appExcel = CreateObject("Excel.Application.11")  
 
Хотелось-бы знать что поменялось и как даная проблема решается  
 
Спасибо  
"  
Только вот слепил все в одну кучу, и текст стал нечитабельным. Так что извеняюсь за оформление.

Перешёл на 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")  
 
Хотелось-бы знать что поменялось и как даная проблема решается  
 
Спасибо

А я пользуюсь во всех книгах следующим макросом. Реально не раз выручал, когда пользователь говорит "не я", а я ему показываю что всетаки он.  
Отображает в листе "Log" кто, что, и когда сделал.  
 
Sub LogFilling(ByVal Target As Range, ByVal SheetName As String)  
           
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 1).NumberFormat = "dd.mm.yyyy hh:mm:ss"  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 1).HorizontalAlignment = xlRight  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 1).Value = Date + Time  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 2).NumberFormat = "@"  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 2).HorizontalAlignment = xlRight  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 2).Value = SheetName & ": " & Target.Address  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 3).HorizontalAlignment = xlRight  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 3).Value = Application.UserName  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 4).HorizontalAlignment = xlRight  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 4).Value = _  
                                               Worksheets("Log").Cells(1, 12).Value  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 5).HorizontalAlignment = xlRight  
   Worksheets("Log").Cells(Worksheets("Log").Cells(1, 11).Value, 5).Value = Target.Value  
   Worksheets("Log").Cells(1, 11).Value = Worksheets("Log").Cells(1, 11).Value + 1  
             
End Sub

Получилось