Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику Cancel = 1 On Error GoTo err 'если произойдет какая-нибудь ошибка, выполнить последнюю строку кода If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек With Target(1, 1) 'указываем, с какой ячейкой работать макросу With Application: .ScreenUpdating = 0: End With 'оптимизация производительности макроса Dim Name$: Name = Application.UserName 'задаём переменную Name, содержащую имя пользователя 'волшебство начинается Dim L&: L = Len(.Value) Dim D$, i&, tmp$, k$ Select Case Application.MoveAfterReturnDirection Case xlDown: D = "UP": Case xlUp: D = "DOWN" Case xlRight: D = "LEFT": Case xlLeft: D = "RIGHT" End Select k = "{F2}^{END}" & IIf(L, "%{ENTER}", "") & Now & " " & Name & ": {ENTER}{" & D & "}" Application.SendKeys k DoEvents 'волшебство закончилось ; ) With .Characters(L + 1, Len(.Value) - L - 1) .Font.Color = IIf(Name = "Иванов А." Or Name = "Андреев П." Or Name = "Васьков А.", vbBlue, vbBlack) 'выделяем дату\время\ФИО в комментарии определённого пользователя End With With .Characters(L + 1, Len(.Value) - L).Font .Name = Application.StandardFont: .Bold = 0: .Italic = 0 .Size = Application.StandardFontSize: .Strikethrough = 0 .Subscript = 0: .Superscript = 0: .ThemeFont = xlThemeFontNone .TintAndShade = 0: .Underline = xlUnderlineStyleNone .OutlineFont = 0: .Shadow = 0: .FontStyle = "обычный" End With .Characters(L).Font.ColorIndex = xlAutomatic End With Application.SendKeys "{F2}" End If err: 'следующая строка дожна быть обязательно выполнена With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With 'оптимизация производительности макроса End Sub
[/vba]
[vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику Cancel = 1 On Error GoTo err 'если произойдет какая-нибудь ошибка, выполнить последнюю строку кода If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек With Target(1, 1) 'указываем, с какой ячейкой работать макросу With Application: .ScreenUpdating = 0: End With 'оптимизация производительности макроса Dim Name$: Name = Application.UserName 'задаём переменную Name, содержащую имя пользователя 'волшебство начинается Dim L&: L = Len(.Value) Dim D$, i&, tmp$, k$ Select Case Application.MoveAfterReturnDirection Case xlDown: D = "UP": Case xlUp: D = "DOWN" Case xlRight: D = "LEFT": Case xlLeft: D = "RIGHT" End Select k = "{F2}^{END}" & IIf(L, "%{ENTER}", "") & Now & " " & Name & ": {ENTER}{" & D & "}" Application.SendKeys k DoEvents 'волшебство закончилось ; ) With .Characters(L + 1, Len(.Value) - L - 1) .Font.Color = IIf(Name = "Иванов А." Or Name = "Андреев П." Or Name = "Васьков А.", vbBlue, vbBlack) 'выделяем дату\время\ФИО в комментарии определённого пользователя End With With .Characters(L + 1, Len(.Value) - L).Font .Name = Application.StandardFont: .Bold = 0: .Italic = 0 .Size = Application.StandardFontSize: .Strikethrough = 0 .Subscript = 0: .Superscript = 0: .ThemeFont = xlThemeFontNone .TintAndShade = 0: .Underline = xlUnderlineStyleNone .OutlineFont = 0: .Shadow = 0: .FontStyle = "обычный" End With .Characters(L).Font.ColorIndex = xlAutomatic End With Application.SendKeys "{F2}" End If err: 'следующая строка дожна быть обязательно выполнена With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With 'оптимизация производительности макроса End Sub
Данные с http://www.profinanceservice.com/ не обновляются возможно потому, что для источника используется статическая ссылка и при обновлении информация берется из кеша.
Данные с http://www.profinanceservice.com/ не обновляются возможно потому, что для источника используется статическая ссылка и при обновлении информация берется из кеша.krosav4ig
9 - это номер строки первой ячейки с формулой если ошибку выдает в столбце код, то возможно там у в исходном диапазоне есть объединенные ячейки, если так, то в формуле перед последней скобкой допишите ;1
обратите внимание на
Код
СТРОКА()-9
9 - это номер строки первой ячейки с формулой если ошибку выдает в столбце код, то возможно там у в исходном диапазоне есть объединенные ячейки, если так, то в формуле перед последней скобкой допишите ;1krosav4ig
Что отправляется командой Application.SendKeys "^{END}"
Ctrl+End так надо что ли? [vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику On Error GoTo err If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек With Target(1, 1) 'указываем, с какой ячейкой работать макросу With Application: .ScreenUpdating = 0: .EnableEvents = 0: End With Dim Name$: Name = Application.UserName Dim L&: L = Len(.Value) Dim char, arr&(), i& ReDim arr(L + (L > 0)) For i = 1 To L: arr(i - 1) = .Characters(i, 1).Font.Color: Next 'если ячейка изначально пуста, то включаем макрос без перевода на новую строку .Value = .Value & IIf(L, vbLf, "") & Now & " " & Name & ": " For i = 1 To L: .Characters(i, 1).Font.Color = arr(i - 1): Next 'With .Characters(InStr(.Value, Name), Len(Name)) ' если раскомментировать эту строку и закометировать следующую, то выделится только имя пользователя With .Characters(L + 1, Len(.Value) - L - 1) .Font.Color = IIf(Name = "krosav4ig", vbRed, vbBlue) End With .Characters(Len(.Value)).Font.ColorIndex = xlAutomatic Application.SendKeys "^{END}" End With End If Cancel = 0 If err.Number Then MsgBox "Ошибка " & err.Number & " (" & err.Description & ") в Worksheet_BeforeDoubleClick модуля Лист2" err: With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With End Sub
Что отправляется командой Application.SendKeys "^{END}"
Ctrl+End так надо что ли? [vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику On Error GoTo err If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек With Target(1, 1) 'указываем, с какой ячейкой работать макросу With Application: .ScreenUpdating = 0: .EnableEvents = 0: End With Dim Name$: Name = Application.UserName Dim L&: L = Len(.Value) Dim char, arr&(), i& ReDim arr(L + (L > 0)) For i = 1 To L: arr(i - 1) = .Characters(i, 1).Font.Color: Next 'если ячейка изначально пуста, то включаем макрос без перевода на новую строку .Value = .Value & IIf(L, vbLf, "") & Now & " " & Name & ": " For i = 1 To L: .Characters(i, 1).Font.Color = arr(i - 1): Next 'With .Characters(InStr(.Value, Name), Len(Name)) ' если раскомментировать эту строку и закометировать следующую, то выделится только имя пользователя With .Characters(L + 1, Len(.Value) - L - 1) .Font.Color = IIf(Name = "krosav4ig", vbRed, vbBlue) End With .Characters(Len(.Value)).Font.ColorIndex = xlAutomatic Application.SendKeys "^{END}" End With End If Cancel = 0 If err.Number Then MsgBox "Ошибка " & err.Number & " (" & err.Description & ") в Worksheet_BeforeDoubleClick модуля Лист2" err: With Application: .ScreenUpdating = 1: .EnableEvents = 1: End With End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек With Target(1, 1) 'указываем, с какой ячейкой работать макросу Dim Name$: Name = Application.UserName If IsEmpty(Target) Then 'если ячейка изначально пуста, то включаем макрос без перевода на новую строку .Value = Now & " " & Name & ": " Else .Value = .Value & vbLf & Now & " " & Name & ": " End If 'With .Characters(InStr(.Value, Name), Len(Name)) ' если раскомментировать эту строку и закометировать следующую, то выделится только имя пользователя With .Characters(Len(.Value), 1) .Font.Color = IIf(Name = "Иванов А.", vbRed, vbBlue) End With Application.SendKeys "^{END}" End With End If Cancel = 0 End Sub
[/vba]
как-то так [vba]
Код
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'включаем действие по клику If Not Intersect(Target, Range("K4:K5000")) Is Nothing Then 'включаем макрос для данного диапазона ячеек With Target(1, 1) 'указываем, с какой ячейкой работать макросу Dim Name$: Name = Application.UserName If IsEmpty(Target) Then 'если ячейка изначально пуста, то включаем макрос без перевода на новую строку .Value = Now & " " & Name & ": " Else .Value = .Value & vbLf & Now & " " & Name & ": " End If 'With .Characters(InStr(.Value, Name), Len(Name)) ' если раскомментировать эту строку и закометировать следующую, то выделится только имя пользователя With .Characters(Len(.Value), 1) .Font.Color = IIf(Name = "Иванов А.", vbRed, vbBlue) End With Application.SendKeys "^{END}" End With End If Cancel = 0 End Sub
добавление значений занимает около 1 минуты, вне зависимости добавляем одно значение или массив.
Автопересчет формул включен? Если да, то попробуйте добавлять данные при отключенном автопересчете, потом выполнить запустить пересчет клавишей F9. выделить диапазон с формулами, которые нужно пересчитать и выполнить макрос [vba]
Код
Sub пересчет() Selection.Calculate End Sub
[/vba]
mrdc, в формуле gling, для последнего значения замените СТРОКА() на 1, для предпоследнего - на 2
добавление значений занимает около 1 минуты, вне зависимости добавляем одно значение или массив.
Автопересчет формул включен? Если да, то попробуйте добавлять данные при отключенном автопересчете, потом выполнить запустить пересчет клавишей F9. выделить диапазон с формулами, которые нужно пересчитать и выполнить макрос [vba]
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
, вот я и предложил формулу )
