|
|
Выполнение макроса после изменения ячейки
Привет всем!
У меня есть макрос, который следит за указанным диапазоном и меняет текст на ссылку:
Код:
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
Можете пожалуйста показать как решить эту проблему.
|
Цитата:
Цитата pedrosoft
Но в моем коде уже используется эта функция при добавлении комментариев в другой диапазон ячеек, из-за чего я получаю ошибку: 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
|
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
|
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
|
Оффтопиком:
Код:
If Not Target Is Nothing Then
|
Я добавил новую функциональность в виде переноса строки в другой лист (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
|
pedrosoft, упакуйте Вашу Рабочую книгу с кодом и содержанием в архив и выложите последний сюда. Укажите, как именно воспроизвести данную ошибку.
|
Вложений: 1
Когда выставляю в строке статус "Решена" вываливается дебагер, после завершения дебагера строка переноситься на архивный лист, но в основном листе все равно остается примечание
|
Во-первых, возьмите в привычку объявлять все переменные и пользовать инструкцию Option Explicit. Во-вторых, если Вы пользуете On Error Resume Next, обрабатывайте возможные ошибки.
Ошибка у Вас возникает после второго вызова процедуры Worksheet_Change(), каковой происходит после этого:
и возврата из неё в первый вызов.
К моменту ошибки Target из первого вызова уже ссылается на более не существующий объект Рабочего листа.
|
Iska, это в дебагере я видел, понимаю почему происходить, но из-за не знания языка не могу исправить. + ниже тоже идет Target, который начнет ругаться:
'если ячейка не в отслеживаемом диапазоне, то выходим
If Intersect(Target, Range("C2:C666")) Is Nothing Then Exit Sub
|
pedrosoft, чтобы что-то подсказать, надо понимать, какую задачу Вы решаете данным кодом.
|
Время: 18:05.
© OSzone.net 2001-