Компьютерный форум OSzone.net  

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)
-   Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)
-   -   Выполнение макроса после изменения ячейки (http://forum.oszone.net/showthread.php?t=346370)

pedrosoft 07-09-2020 10:31 2933173

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

У меня есть макрос, который следит за указанным диапазоном и меняет текст на ссылку:
Код:

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 07-09-2020 10:49 2933176

Цитата:

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


pedrosoft 07-09-2020 11:54 2933189

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 07-09-2020 12:15 2933191

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 07-09-2020 20:31 2933272

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

Iska 07-09-2020 20:43 2933273

Оффтопиком:
Цитата:

Цитата pedrosoft
If Target <> 0 Then »

Цитата:

Цитата pedrosoft
If Target <> "" Then »

Код:

If Not Target Is Nothing Then

pedrosoft 11-09-2020 14:40 2933703

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

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

pedrosoft 15-09-2020 10:32 2934091

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

Iska 15-09-2020 22:11 2934168

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

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

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

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

pedrosoft 15-09-2020 22:44 2934172

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

Iska 17-09-2020 18:27 2934284

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


Время: 18:05.

Время: 18:05.
© OSzone.net 2001-