Страницы: 1
RSS
фиксированная дата изменения соседней ячейки, фиксированная дата изменения соседней ячейки для smart таблиц
 

Доброго времени суток, вопрос по замусоленной теме "фиксированная дата изменения соседней ячейки"
Начал изучать архив данного форума и другие ресурсы, но макросы предлогаемые имели ряд недостатков, а сцепить их в тот что нужен, ума не хватило.

Мы имеем вот такой код взят из темы Автоматическая вставка текущей даты в ячейку при вводе данных

Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False ' отключает обработку событий для исключения зацикливания или выполнения незапланированных действий
      For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, Range("F2:F100")) Is Nothing Then  'если изменененная ячейка попадает в диапазон A2:A100
On Error Resume Next ' Выполнение пойдет дальше, несмотря на ошибку, вероятно опасная функция
            If IsEmpty(Target) Then ' если цель/цели пустые либо очистили цель
             Target(1, -0) = Empty ' то очистит ячейку с датой, слева от цели
     Else
      With Target(1, -0) ' если цель/цели не пустая
      ' нужен вариант для вставки фиксированного значения к примеру "ХЗ"
       .Value = Now ' вписывается дата (текущая)
        .EntireColumn.AutoFit ' подстройка ячейки
       End With ' заканчивает  with
            End If ' заканчивает 1ый if
       End If ' заканчивает 2ой if
Next cell ' к слудующей ячейки
Application.ScreenUpdating = True ' возвращает в исходное положение обработку событий для исключения зацикливания или выполнения незапланированных действий
End Sub

какой минус в моем использовании, есть таблица SMART, то есть с автозаполнением и авто расширением.
данный код написан под фиксированный диапазон, я не использую SMART таблицу обычным образом, то есть на пустой после последней строчки вводишь данные, а смарт включает автозаполнение и расширение.

у меня кнопка макроса, запускает между 2 и3 строкой вставить новую строку (с форматом смарт таблицы)
- в этом случае код ругается.

//почему так, конкретно таблица называется "TO DO", разные задачи на день месяц  и тп, в идеале не хочется прокручивать листы постоянно вниз, в обще в планах сделать так что бы обработанные задания строки перемещались (автосортировались) в самый низ таблицы. а активные задания всегда оставились на глазах, при возникновении новой задачи, путем кнопки вносится задание.

Что хотелось бы, указать динамический дипазон к примеру
Код
 dim lRow&
 If Target.Cells.Count > 1 Then Exit Sub
 lRow = Cells(Rows.Count, "F").end(xlUp).row
 If Not Intersect(Target, Range("F2:F" & lRow)) Is Nothing Then

Или - использовав имя диапазона "Tracker_list[[#Headers],[ACTION]]" эта цель мониторинга, а дату вписывать в "Tracker_list[[#Headers],[Date of completion]]" ну естественно обновлять ячейки находящихся на одной строке.( в данном случае слева от заполненной)

+так же было бы хорошо сделать, что бы макрос гулял в диапазоне столбца умной таблице, что бы не было ложных или ошибочных обработок.
+ вместо пустого значения, что бы могли написать какой нибудь фиксировнный текст .

То, что я на собирал сверху работает корректно (может это не очень граммотный пример) в условиях если мы работаем с фикс таблицей.

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

заранее спасибо

Изменено: Ар.т - 18.11.2019 13:26:34
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False ' отключает обработку событий для исключения зацикливания или выполнения незапланированных действий
      Dim cell As Range
      Application.EnableEvents = False
      
      For Each cell In Target   'проходим по всем измененным ячейкам
       If Not Intersect(cell, ListObjects("Tracker_list").ListColumns("ACTION").DataBodyRange) Is Nothing Then   'если изменененная ячейка попадает в диапазон A2:A100
On Error Resume Next ' Выполнение пойдет дальше, несмотря на ошибку, вероятно опасная функция
            If IsEmpty(Target) Then ' если цель/цели пустые либо очистили цель
             Target(1, -0) = Empty ' то очистит ячейку с датой, слева от цели
     Else
      'With Target(1, -0) ' если цель/цели не пустая
      ' нужен вариант для вставки фиксированного значения к примеру "ХЗ"
       
      With Cells(Target.Row, ListObjects("Tracker_list").ListColumns("Date of completion").DataBodyRange.Column)
       
       .Value = Now ' вписывается дата (текущая)
        .EntireColumn.AutoFit ' подстройка ячейки
       End With ' заканчивает  with
            End If ' заканчивает 1ый if
       End If ' заканчивает 2ой if
Next cell ' к слудующей ячейки
Application.ScreenUpdating = True ' возвращает в исходное положение обработку событий для исключения зацикливания или выполнения незапланированных действий
Application.EnableEvents = True
      
End Sub
 
МатросНаЗебре, при много блогадарен, а подскажите на что заменить  Target(1, -0) = Empty  что бы мог вписывать определенное значение.

так же для тех кому понадобится - приложил файл с предложенным кодом - наглядная работа
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Dim cell As Range
    Application.EnableEvents = False
    For Each cell In Target
        If Not Intersect(cell, ListObjects("Tracker_list").ListColumns("ACTION").DataBodyRange) Is Nothing Then
            On Error Resume Next
            With Cells(Target.Row, ListObjects("Tracker_list").ListColumns("Date of completion").DataBodyRange.Column)
                If IsEmpty(Target) Then
                    .Value = "Определённое значение"
                Else
                    .Value = Now
                    .EntireColumn.AutoFit
                End If
            End With
        End If
    Next cell
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
Изменено: МатросНаЗебре - 18.11.2019 13:39:47 (Заменил Empty на "Определённое значение".)
 
А можно узнать, в условиях, если на листе имеются разные виды фиксаций дат изменения ? и разные диапазоны ?

пример ниже, за ранее спасибо.
я пробовал несколько "Private Sub Worksheet_Change(ByVal Target As Range)" на одном листе, но видимо это как бы начало книги и sub end конец,
пробовал разбивать по группам, но там видимо нельзя что бы не которые функции повторялись в одном большом коде, хотя c IF и end IF , мы можем часто использовать.

странно когда код сюда прописывал через фукнцию ответа отображение кода ввиде текста, окно все аккуратно показывает, а при ответе все в кашу свливается
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False ' отключает обработку событий для исключения зацикливания или выполнения незапланированных действийDim NewCellValue$, OldComment$
Dim cell As Range
     
    'если ячейка не в отслеживаемом диапазоне, то выходим
    If Intersect(Target, Range("B48")) Is Nothing Then Exit Sub
     
    'перебираем все ячейки в измененной области
    For Each cell In Intersect(Target, Range("B48"))
        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    
     For Each cell In Target   'проходим по всем измененным ячейкам
     If Not Intersect(cell, Range("F3:F18")) Is Nothing Then  'если изменененная ячейка попадает в диапазон A2:A100
'On Error Resume Next ' Выполнение пойдет дальше, несмотря на ошибку, вероятно опасная функция
     If IsEmpty(Target) Then ' если цель/цели пустые либо очистили цель
          Target(1, 2) = Empty ' то очистит ячейку с датой, слева от цели
Else
          With Target(1, 2) ' если цель/цели не пустая
      ' нужен вариант для вставки фиксированного значения к примеру "ХЗ"
         .Value = Now ' вписывается дата (текущая)
         .EntireColumn.AutoFit ' подстройка ячейки
     End With ' заканчивает  with
        End If ' заканчивает 1ый if
        End If ' заканчивает 2ой if
 Next cell ' к слудующей ячейки
 
 
   For Each cell In Target   'проходим по всем измененным ячейкам
     If Not Intersect(cell, Range("M3:M18")) Is Nothing Then  'если изменененная ячейка попадает в диапазон A2:A100
'On Error Resume Next ' Выполнение пойдет дальше, несмотря на ошибку, вероятно опасная функция
     If IsEmpty(Target) Then ' если цель/цели пустые либо очистили цель
          Target(1, 2) = Empty ' то очистит ячейку с датой, слева от цели
Else
          With Target(1, 2) ' если цель/цели не пустая
      ' нужен вариант для вставки фиксированного значения к примеру "ХЗ"
         .Value = Now ' вписывается дата (текущая)
         .EntireColumn.AutoFit ' подстройка ячейки
     End With ' заканчивает  with
        End If ' заканчивает 1ый if
        End If ' заканчивает 2ой if
 Next cell ' к слудующей ячейкиApplication.ScreenUpdating = True ' возвращает в исходное положение обработку событий для исключения зацикливания
End Sub
Изменено: Ар.т - 18.11.2019 15:40:09
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Dim cell As Range
    Application.EnableEvents = False
    For Each cell In Target
        If Not Intersect(cell, ListObjects("Tracker_list").ListColumns("ACTION").DataBodyRange) Is Nothing Then
            On Error Resume Next
            With Cells(Target.Row, ListObjects("Tracker_list").ListColumns("Date of completion").DataBodyRange.Column)
                If IsEmpty(Target) Then
                    .Value = "Определённое значение"
                Else
                    .Value = Now
                    .EntireColumn.AutoFit
                End If
            End With
        ElseIf Not Intersect(cell, ListObjects("Tracker_list").ListColumns("ACTION2").DataBodyRange) Is Nothing Then
            On Error Resume Next
            With Cells(Target.Row, ListObjects("Tracker_list").ListColumns("Date of completion2").DataBodyRange.Column)
                If IsEmpty(Target) Then
                    .Value = "Определённое значение"
                Else
                    .Value = Now
                    .EntireColumn.AutoFit
                End If
            End With
        ElseIf Not Intersect(cell, ListObjects("Tracker_list").ListColumns("ACTION3").DataBodyRange) Is Nothing Then
            On Error Resume Next
            With Cells(Target.Row, ListObjects("Tracker_list").ListColumns("Date of completion3").DataBodyRange.Column)
                If IsEmpty(Target) Then
                    .Value = "Определённое значение"
                Else
                    .Value = Now
                    .EntireColumn.AutoFit
                End If
            End With
        End If
    Next cell
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
 
МатросНаЗебре снова спасибо, но не много не то, что требовалась.
Я пытался сам подстроить, вышло даже так , что не много уменьшил размер кода. но не работает в связке с
https://www.planetaexcel.ru/techniques/5/208/

можете проверить ?
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim cell As Range
    For Each cell In Target
    'если ячейка не в отслеживаемом диапазоне, то выходим ( дописать такую команду для оптимизации)
        If Not Intersect(cell, Range("F3:F18, K3:K13, P3:P18")) Is Nothing Then
           On Error Resume Next
            With Target(1, 2)
            If IsEmpty(Target) Then
            .Value = "хз"
       
       Else
            
            .Value = Now
            '.EntireColumn.AutoFit
            End If
            End With
            ElseIf Not Intersect(cell, Range("B48")) Is Nothing Then Exit Sub
    With Cells(Target, Range("B48"))
        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
   
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
   
    
 End Sub

 
Уважаемые кто мог бы помочь ? Up!
Смог добится того что полный код отрабатывает на половину, то есть первая часть работает, но вторая при действиях не реагирует, есть подозрения проблеме в DIM нужно было еще задать как то, но не знаю.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
     Dim NewCellValue$, OldComment$
  
     
     Dim cell As Range
     
    For Each cell In Target
    'åñëè ÿ÷åéêà íå â îòñëåæèâàåìîì äèàïàçîíå, òî âûõîäèì ( äîïèñàòü òàêóþ êîìàíäó äëÿ îïòèìèçàöèè)
        If Not Intersect(cell, Range("F3:F18, K3:K13, P3:P18")) Is Nothing Then
        'On Error Resume Next
            With Target(1, 2)
            If IsEmpty(Target) Then
            .Value = "õç"
       Else
            .Value = Now
            '.EntireColumn.AutoFit
            End If
            End With
        
 
    ElseIf Intersect(Target, Range("B48")) Is Nothing Then
    With cell(Target, Range("B48"))
        If IsEmpty(cell) Then
            NewCellValue = "ß÷åéêà î÷èùåíà" 'ôèêñèðóåì î÷èñòêó ÿ÷åéêè
        Else
            NewCellValue = cell.Formula     'èëè åå ñîäåðæèìîå
       End If
       End With
       '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
           End If
      Application.ScreenUpdating = True
    Application.EnableEvents = True
   Next cell
 End Sub

Изменено: Ар.т - 20.11.2019 10:15:09
 
Нужно при изменении ячейки В48 изменить комментарий этой ячейки?
 
Да совершенно верно,
вот так работает та часть кода с темы данного сайта
https://www.planetaexcel.ru/techniques/5/208/
Изменено: Ар.т - 20.11.2019 12:22:28
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   Dim NewCellValue$, OldComment$
   Dim cell As Range
   For Each cell In Target
        If Not Intersect(cell, Range("F3:F18, K3:K13, P3:P18")) Is Nothing Then
            With Target(1, 2)
            If IsEmpty(Target) Then
            .Value = "oc"
       Else
            .Value = Now
            End If
            End With
         
    ElseIf Not Intersect(Target, Range("B48")) Is Nothing Then
        With Range("B48")
            If IsEmpty(cell) Then
                NewCellValue = "Что-то"
            Else
                NewCellValue = cell.Formula
            End If
            
            On Error Resume Next
                OldComment = .Comment.Text & Chr(10)
                .Comment.Delete
            On Error GoTo 0
            .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
    End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
   Next cell
 End Sub
 
Уважаемый МатросНаЗебре Огромное спасибо, за ваше время и помощь.
идеально работает.

Тема исчерпана можно закрывать. Спасибо всем.
Страницы: 1
Наверх