|
Компьютерный форум OSzone.net » Сфера Microsoft » Microsoft Office (Word, Excel, Outlook и т.д.) » Разное - Выполнение макроса после изменения ячейки |
|
|
Разное - Выполнение макроса после изменения ячейки
|
Новый участник Сообщения: 31 |
Профиль | Отправить PM | Цитировать Привет всем!
У меня есть макрос, который следит за указанным диапазоном и меняет текст на ссылку: Private Sub CreateHypelinkInTextCell() Dim iCell As Range, iText$ For Each iCell In [A2:A666] iText = iCell.Text If iText <> "" Then iCell.Hyperlinks.Add iCell, ("https://test.ru/issues/" & iText) Next End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A1:A666")) Is Nothing Then If Target <> 0 Then Call CreateHypelinkInTextCell End If End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim NewCellValue$, OldComment$ Dim cell As Range 'если ячейка не в отслеживаемом диапазоне, то выходим If Intersect(Target, Range("C2:C666")) Is Nothing Then Exit Sub 'перебираем все ячейки в измененной области For Each cell In Intersect(Target, Range("C2:C666")) If IsEmpty(cell) Then NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки Else NewCellValue = cell.Formula 'или ее содержимое End If On Error Resume Next With cell OldComment = .Comment.Text & Chr(10) .Comment.Delete 'удаляем старое примечание (если было) .AddComment 'добавляем новое и вводим в него текст .Comment.Text Text:=OldComment & Application.UserName & " " & _ Format(Now, "MM.DD.YY h:MM:ss") & ": " & NewCellValue .Comment.Shape.TextFrame.AutoSize = True 'делаем автоподбор размера .Comment.Shape.TextFrame.Characters.Font.Size = 8 End With Next cell End Sub |
|
Отправлено: 10:31, 07-09-2020 |
Динохромный Сообщения: 690
|
Профиль | Отправить PM | Цитировать Цитата pedrosoft:
Сведите содержимое ваших функций в одну общую: Пример кода
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("A1:A666")) Is Nothing Then If Target <> 0 Then Call CreateHypelinkInTextCell End If End If Dim NewCellValue$, OldComment$ Dim cell As Range 'если ячейка не в отслеживаемом диапазоне, то выходим If Intersect(Target, Range("C2:C666")) Is Nothing Then Exit Sub 'перебираем все ячейки в измененной области For Each cell In Intersect(Target, Range("C2:C666")) If IsEmpty(cell) Then NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки Else NewCellValue = cell.Formula 'или ее содержимое End If On Error Resume Next With cell OldComment = .Comment.Text & Chr(10) .Comment.Delete 'удаляем старое примечание (если было) .AddComment 'добавляем новое и вводим в него текст .Comment.Text Text:=OldComment & Application.UserName & " " & _ Format(Now, "MM.DD.YY h:MM:ss") & ": " & NewCellValue .Comment.Shape.TextFrame.AutoSize = True 'делаем автоподбор размера .Comment.Shape.TextFrame.Characters.Font.Size = 8 End With Next cell End Sub |
|
------- Отправлено: 10:49, 07-09-2020 | #2 |
Для отключения данного рекламного блока вам необходимо зарегистрироваться или войти с учетной записью социальной сети. Если же вы забыли свой пароль на форуме, то воспользуйтесь данной ссылкой для восстановления пароля. |
Новый участник Сообщения: 31
|
Профиль | Отправить PM | Цитировать a_axe, спасибо это работает! А можете подсказать как мне вообще отказаться от функции CreateHypelinkInTextCell и перенести ее функционал в:
|
Отправлено: 11:54, 07-09-2020 | #3 |
Динохромный Сообщения: 690
|
Профиль | Отправить PM | Цитировать pedrosoft, попробуйте такой вариант:
Скрытый текст
Private Sub Worksheet_Change(ByVal Target As Range) Dim iCell As Range, iText$ If Not Intersect(Target, Range("A1:A666")) Is Nothing Then If Target <> 0 Then For Each iCell In [A2:A666] iText = iCell.Text If iText <> "" Then iCell.Hyperlinks.Add iCell, ("https://test.ru/issues/" & iText) Next End If End If Dim NewCellValue$, OldComment$ Dim cell As Range 'если ячейка не в отслеживаемом диапазоне, то выходим If Intersect(Target, Range("C2:C666")) Is Nothing Then Exit Sub 'перебираем все ячейки в измененной области For Each cell In Intersect(Target, Range("C2:C666")) If IsEmpty(cell) Then NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки Else NewCellValue = cell.Formula 'или ее содержимое End If On Error Resume Next With cell OldComment = .Comment.Text & Chr(10) .Comment.Delete 'удаляем старое примечание (если было) .AddComment 'добавляем новое и вводим в него текст .Comment.Text Text:=OldComment & Application.UserName & " " & _ Format(Now, "MM.DD.YY h:MM:ss") & ": " & NewCellValue .Comment.Shape.TextFrame.AutoSize = True 'делаем автоподбор размера .Comment.Shape.TextFrame.Characters.Font.Size = 8 End With Next cell End Sub |
------- Отправлено: 12:15, 07-09-2020 | #4 |
Новый участник Сообщения: 31
|
Профиль | Отправить PM | Цитировать Работает, спасибо!
|
|
Отправлено: 20:31, 07-09-2020 | #5 |
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать |
Отправлено: 20:43, 07-09-2020 | #6 |
Новый участник Сообщения: 31
|
Профиль | Отправить PM | Цитировать Я добавил новую функциональность в виде переноса строки в другой лист (Archive.TEST), после появления в ячейки значения "Решена":
Private Sub Worksheet_Change(ByVal Target As Range) Dim iText$ Dim iCell As Range 'если ячейка в отслеживаемом диапазоне, то продолжаем If Not Intersect(Target, Range("A2:A666")) Is Nothing Then 'перебираем все ячейки в измененной области For Each iCell In Intersect(Target, Range("A2:A666")) iText = iCell.Text If iText <> "" Then iCell.Hyperlinks.Add iCell, ("https://test.ru/issues/" & iText) Next End If Set trgt_rng = Range([D2], [D2].End(xlDown)) If Not Intersect(trgt_rng, Target) Is Nothing And Target.Cells(1).Value = "Решена" Then Set out_rng = Worksheets("Archive.TEST").[A1].Offset(Cells.Rows.Count - 1).End(xlUp).Offset(1) Target.EntireRow.Copy out_rng Target.EntireRow.Delete Application.CutCopyMode = False End If Dim NewCellValue$, OldComment$ Dim bCell As Range 'если ячейка не в отслеживаемом диапазоне, то выходим If Intersect(Target, Range("C2:C666")) Is Nothing Then Exit Sub 'перебираем все ячейки в измененной области For Each bCell In Intersect(Target, Range("C2:C666")) If IsEmpty(bCell) Then NewCellValue = "Ячейка очищена" 'фиксируем очистку ячейки Else NewCellValue = bCell.Formula 'или ее содержимое End If On Error Resume Next With bCell OldComment = .Comment.Text & Chr(10) .Comment.Delete 'удаляем старое примечание (если было) .AddComment 'добавляем новое и вводим в него текст .Comment.Text Text:=OldComment & Application.UserName & " " & Format(Now, "MM.DD.YY h:MM") & ": " & NewCellValue .Comment.Shape.TextFrame.AutoSize = True 'делаем автоподбор размера .Comment.Shape.TextFrame.Characters.Font.Size = 8 End With Next bCell End Sub Подскажите почему этой проверке не нравиться, как я делаю Target.EntireRow.Delete |
Отправлено: 14:40, 11-09-2020 | #7 |
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать pedrosoft, упакуйте Вашу Рабочую книгу с кодом и содержанием в архив и выложите последний сюда. Укажите, как именно воспроизвести данную ошибку.
|
Отправлено: 22:47, 14-09-2020 | #8 |
Новый участник Сообщения: 31
|
Профиль | Отправить PM | Цитировать Когда выставляю в строке статус "Решена" вываливается дебагер, после завершения дебагера строка переноситься на архивный лист, но в основном листе все равно остается примечание
|
Отправлено: 10:32, 15-09-2020 | #9 |
Ветеран Сообщения: 27449
|
Профиль | Отправить PM | Цитировать Во-первых, возьмите в привычку объявлять все переменные и пользовать инструкцию Option Explicit. Во-вторых, если Вы пользуете On Error Resume Next, обрабатывайте возможные ошибки.
Ошибка у Вас возникает после второго вызова процедуры Worksheet_Change(), каковой происходит после этого: Скрытый текст
и возврата из неё в первый вызов. К моменту ошибки Target из первого вызова уже ссылается на более не существующий объект Рабочего листа. |
Отправлено: 22:11, 15-09-2020 | #10 |
|
Участник сейчас на форуме | Участник вне форума | Автор темы | Сообщение прикреплено |
| |||||
Название темы | Автор | Информация о форуме | Ответов | Последнее сообщение | |
2013 - [решено] Нумерация ячейки в зависимости от другой ячейки | subuday77 | Microsoft Office (Word, Excel, Outlook и т.д.) | 5 | 19-02-2018 16:56 | |
2013 - Ссылка на ячейки другого листа, с возможностью изменения порядка ячеек | btescm | Microsoft Office (Word, Excel, Outlook и т.д.) | 5 | 04-09-2014 23:16 | |
2010 - [решено] Выполнение макроса при фильтре | Invincible | Microsoft Office (Word, Excel, Outlook и т.д.) | 2 | 10-09-2013 21:32 | |
Выполнение макроса по звуковому сигналу. | bongubong | Хочу все знать | 3 | 01-06-2012 08:49 | |
2003/XP/2000 - [решено] Excel | Отмена изменений после макроса | AlexM | Microsoft Office (Word, Excel, Outlook и т.д.) | 3 | 07-02-2010 03:19 |
|