Имя пользователя:
Пароль:  
Помощь | Регистрация | Забыли пароль?  | Правила  

Компьютерный форум OSzone.net » Сфера Microsoft » Microsoft Office (Word, Excel, Outlook и т.д.) » Разное - Выполнение макроса после изменения ячейки

Ответить
Настройки темы
Разное - Выполнение макроса после изменения ячейки

Новый участник


Сообщения: 27
Благодарности: 0

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

Отправлено: 10:31, 07-09-2020

 

Ветеран


Contributor


Сообщения: 553
Благодарности: 260

Профиль | Отправить PM | Цитировать


Цитата 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

-------
[Форум Word и Excel] - [Как запустить Word, Excel и Outlook в безопасном режиме?] - [Как удалить шаблон Word Normal.dotm?]

Это сообщение посчитали полезным следующие участники:

Отправлено: 10:49, 07-09-2020 | #2



Для отключения данного рекламного блока вам необходимо зарегистрироваться или войти с учетной записью социальной сети.

Если же вы забыли свой пароль на форуме, то воспользуйтесь данной ссылкой для восстановления пароля.


Новый участник


Сообщения: 27
Благодарности: 0

Профиль | Отправить PM | Цитировать


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

Отправлено: 11:54, 07-09-2020 | #3


Ветеран


Contributor


Сообщения: 553
Благодарности: 260

Профиль | Отправить 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

-------
[Форум Word и Excel] - [Как запустить Word, Excel и Outlook в безопасном режиме?] - [Как удалить шаблон Word Normal.dotm?]

Это сообщение посчитали полезным следующие участники:

Отправлено: 12:15, 07-09-2020 | #4


Новый участник


Сообщения: 27
Благодарности: 0

Профиль | Отправить PM | Цитировать


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

Отправлено: 20:31, 07-09-2020 | #5


Ветеран


Contributor


Сообщения: 26290
Благодарности: 7645

Профиль | Отправить PM | Цитировать


Оффтопиком:
Цитата pedrosoft:
If Target <> 0 Then »
Цитата pedrosoft:
If Target <> "" Then »
Код: Выделить весь код
If Not Target Is Nothing Then
Это сообщение посчитали полезным следующие участники:

Отправлено: 20:43, 07-09-2020 | #6


Новый участник


Сообщения: 27
Благодарности: 0

Профиль | Отправить 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
Но при работе макроса получаю ошибку в строке:
Код: Выделить весь код
If Intersect(Target, Range("C2:C666")) Is Nothing Then Exit Sub
Подскажите почему этой проверке не нравиться, как я делаю Target.EntireRow.Delete

Отправлено: 14:40, 11-09-2020 | #7


Ветеран


Contributor


Сообщения: 26290
Благодарности: 7645

Профиль | Отправить PM | Цитировать


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

Отправлено: 22:47, 14-09-2020 | #8


Новый участник


Сообщения: 27
Благодарности: 0

Профиль | Отправить PM | Цитировать


Вложения
Тип файла: zip TEST.zip
(23.5 Kb, 2 просмотров)

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

Отправлено: 10:32, 15-09-2020 | #9


Ветеран


Contributor


Сообщения: 26290
Благодарности: 7645

Профиль | Отправить PM | Цитировать


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

Ошибка у Вас возникает после второго вызова процедуры Worksheet_Change(), каковой происходит после этого:
Скрытый текст

и возврата из неё в первый вызов.

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

Отправлено: 22:11, 15-09-2020 | #10



Компьютерный форум OSzone.net » Сфера Microsoft » Microsoft Office (Word, Excel, Outlook и т.д.) » Разное - Выполнение макроса после изменения ячейки

Участник сейчас на форуме Участник сейчас на форуме Участник вне форума Участник вне форума Автор темы Автор темы Шапка темы Сообщение прикреплено

Похожие темы
Название темы Автор Информация о форуме Ответов Последнее сообщение
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




 
Переход