Выполнение макроса после изменения ячейки

[pedrosoft]

Привет всем!

У меня есть макрос, который следит за указанным диапазоном и меняет текст на ссылку:
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

Но в моем коде уже используется эта функция при добавлении комментариев в другой диапазон ячеек, из-за чего я получаю ошибку: ambiguous name detected Worksheet_Change
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

Можете пожалуйста показать как решить эту проблему.

[a_axe]

Но в моем коде уже используется эта функция при добавлении комментариев в другой диапазон ячеек, из-за чего я получаю ошибку: ambiguous name detected Worksheet_Change »
Функция автоматически вызывается при изменении ячеек рабочего листа, а у вас таких функций две. Соответственно, такого быть не должно быть, о чем и указано в ошибке (даже в теории непонятно - какую нужно запускать, если обе - то какую первой, какую второй).

Сведите содержимое ваших функций в одну общую:
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

[pedrosoft]

a_axe, спасибо это работает! А можете подсказать как мне вообще отказаться от функции CreateHypelinkInTextCell и перенести ее функционал в:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A666")) Is Nothing Then
If Target <> "" Then
Call CreateHypelinkInTextCell
End If
End If

[a_axe]

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

[pedrosoft]

Работает, спасибо!

[Iska]

Оффтопиком:
If Target <> 0 Then »
If Target <> "" Then »
If Not Target Is Nothing Then

[pedrosoft]

Я добавил новую функциональность в виде переноса строки в другой лист (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

Но при работе макроса получаю ошибку в строке:
If Intersect(Target, Range("C2:C666")) Is Nothing Then Exit Sub

Подскажите почему этой проверке не нравиться, как я делаю Target.EntireRow.Delete

[Iska]

pedrosoft, упакуйте Вашу Рабочую книгу с кодом и содержанием в архив и выложите последний сюда. Укажите, как именно воспроизвести данную ошибку.

[pedrosoft]

Когда выставляю в строке статус "Решена" вываливается дебагер, после завершения дебагера строка переноситься на архивный лист, но в основном листе все равно остается примечание

[Iska]

Во-первых, возьмите в привычку объявлять все переменные и пользовать инструкцию Option Explicit. Во-вторых, если Вы пользуете On Error Resume Next, обрабатывайте возможные ошибки.

Ошибка у Вас возникает после второго вызова процедуры Worksheet_Change(), каковой происходит после этого:
https://i.imgur.com/GWCkIEK.png
и возврата из неё в первый вызов.

К моменту ошибки Target из первого вызова уже ссылается на более не существующий объект Рабочего листа.

[pedrosoft]

Iska, это в дебагере я видел, понимаю почему происходить, но из-за не знания языка не могу исправить. + ниже тоже идет Target, который начнет ругаться:
'если ячейка не в отслеживаемом диапазоне, то выходим
If Intersect(Target, Range("C2:C666")) Is Nothing Then Exit Sub

[Iska]

pedrosoft, чтобы что-то подсказать, надо понимать, какую задачу Вы решаете данным кодом.