Як автоматично заповнити дату в комірці, коли сусідня комірка оновлюється в Excel?
Іноді, під час оновлення комірки в певному стовпці, вам може знадобитися позначити останню дату оновлення. У цій статті буде рекомендовано метод VBA для вирішення цієї проблеми. Коли осередок оновиться, сусідня комірка негайно автоматично заповниться поточною датою.
Автоматично заповнювати поточну дату в комірці, коли сусідня комірка оновлюється кодом VBA
Припустимо, дані, які вам потрібно оновити, знаходять у стовпці B, і коли осередок у стовпці B оновлюється, поточна дата буде заповнена у сусідній комірці стовпця A. Дивіться знімок екрана:
Ви можете запустити такий код VBA, щоб вирішити цю проблему.
1. Клацніть правою кнопкою миші вкладку аркуша, яку потрібно автоматично заповнити датою на основі сусідньої оновленої комірки, а потім натисніть Переглянути код з меню, що клацне правою кнопкою миші.
2. У вікні Microsoft Visual Basic for Applications скопіюйте та вставте наведений нижче код VBA у вікно коду.
Код VBA: автоматичне заповнення поточної дати в комірці, коли сусідня комірка оновлюється
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("B:B")) Is Nothing) Then _
Target.Offset(0, -1) = Date
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("B:B"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, -1) = Date
Next
End If
Application.EnableEvents = True
End If
End Sub
примітки:
1). У коді B: B означає, що оновлені дані знаходяться в стовпці B.
2). -1 означає, що поточна дата буде заповнена в лівому стовпці стовпця B. Якщо ви хочете, щоб поточна дата заповнилася в стовпці C, змініть -1 на 1.
3. прес інший + Q клавіші одночасно, щоб закрити Microsoft Visual Basic для додатків вікна.
Відтепер при оновленні комірок у стовпці B сусідня комірка у стовпці A буде негайно заповнена поточною датою. Дивіться знімок екрана:
Найкращі інструменти для підвищення продуктивності офісу
Kutools для Excel вирішує більшість ваших проблем і збільшує продуктивність на 80%
Повторне використання: Швидко вставте складні формули, діаграми і все, що ви використовували раніше; Шифрувати комірки з паролем; Створити список розсилки та надсилати електронні листи ...
Супер формула бар (легко редагувати кілька рядків тексту та формули); Макет читання (легко читати та редагувати велику кількість комірок); Вставте у відфільтрований діапазон...
Об’єднати клітинки / рядки / стовпці без втрати даних; Вміст розділених комірок; Об'єднати повторювані рядки / стовпці... Запобігання дублюючим клітинам; Порівняйте діапазони...
Виберіть Повторюваний або Унікальний Рядки; Виберіть Пусті рядки (усі клітинки порожні); Супер знахідка та нечітка знахідка у багатьох робочих зошитах; Випадковий вибір ...
Точна копія Кілька клітинок без зміни посилання на формулу; Автоматичне створення посилань на кілька аркушів; Вставте кулі, Прапорці та інше ...
Витяг тексту, Додати текст, Видалити за позицією, Видаліть пробіл; Створення та друк проміжних підсумків підкачки; Перетворення вмісту комірок та коментарів...
Супер фільтр (зберегти та застосувати схеми фільтрів до інших аркушів); Розширене сортування за місяцем / тижнем / днем, частотою та іншим; Спеціальний фільтр жирним, курсивом ...
Поєднайте робочі зошити та робочі аркуші; Об’єднати таблиці на основі ключових стовпців; Розділіть дані на кілька аркушів; Пакетне перетворення xls, xlsx та PDF...
Понад 300 потужних функцій. Підтримує Office / Excel 2007-2019 та 365. Підтримує всі мови. Простота розгортання на вашому підприємстві чи в організації. Повна функція 30-денної безкоштовної пробної версії. 60-денна гарантія повернення грошей.
I'm inputting this code into my excel workbook and nothing is happening. Could anyone please help? Ideally, I would like when something is put into column A, time would be put into column B.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Extendoffice 2020/10/12
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("A:A")) Is Nothing) Then _
Target.Offset(0, 1) = Time
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("A:A"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, 1) = Time
Next
End If
Application.EnableEvents = True
End If
End Sub
If you want to enter a number, please replace the text Date with the number directly in the code. For enter a text string, please replace the text Date in the code with "you text string" (the double quotes are included).
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Extendoffice 2020/09/28
Dim xRg As Range, xCell As Range
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("B:B")) Is Nothing) Then _
Target.Offset(0, -1) = "a text string" 'Or directly enter a number
Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("B:B"))
If (Not xRg Is Nothing) Then
For Each xCell In xRg
xCell.Offset(0, -1) = "a text string" 'Or directly enter a number
Next
End If
Application.EnableEvents = True
End If
End Sub
Does anyone know if there is a way to auto-populate and lock to prevent inputter from changing the date? When I lock the cells and protect the document then the cells do not populate at all.
Hi Harry,
The below VBA code can help you solve the problem. Please specify the range as much as possible in the code. Thank you for your comment.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Extendoffice 20191017
Dim xRg As Range, xCell As Range
Dim xInt As Integer
On Error Resume Next
If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("B:BP")) Is Nothing) Then
Application.EnableEvents = False
xInt = Target.Row
Me.Range("A" & xInt).Value = Date
Application.EnableEvents = True
End If
End If
End Sub
Hi Abbey,
In the above code, please replace this line
"xCell.Offset(0, -1) = Date"
with
"xCell.Offset(0, -1) = Format(Now(), "yyyy-MM-dd hh:mm:ss")".
Hope I can help. Thank you for your comment.
Hello, I need some help. I am trying to populate the current date into column A if any cells B through N are modified. The offset is throwing me off. Can this code be written to auto populate the date in Column A specifically?
Hi Joe,
The below VBA code can help you solve the problem. Please have a try and thank you for your comment.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Extendoffice 20190924 Dim xRg As Range, xCell As Range
Dim xInt As Integer On Error Resume Next
If (Target.Count = 1) Then If (Not Application.Intersect(Target, Me.Range("B:N")) Is Nothing) Then
Application.EnableEvents = False xInt = Target.Row
Me.Range("A" & xInt).Value = Date Application.EnableEvents = True
End If End If
End Sub
Hi. I'm trying to use the "Auto Populate Current Date In Cell When Adjacent Cell Is Updated With VBA Code". This works on Sheet 1, but I have 11 other sheets I need the code to work on. Please advise. I'm not VBA saavy at all so I appreciate any help I can get!
I used this code to auto populate a column and now wish to auto populate more columns based on date entered into column H. In other words, once a date is entered can I auto populate columns to add date 90, 60, and 30 days out?
Hi Tracey,
The following VBA code can help you solve the probem. Please have a try.
Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim xRg As Range, xCell As Range
Dim xRgAddress As String xRgAddress = "H:H"
On Error Resume Next If (Target.count = 1) Then
If (Not Application.Intersect(Target, Me.Range(xRgAddress)) Is Nothing) Then Target.Offset(0, 1) = Date + 90
Target.Offset(0, 2) = Date + 60 Target.Offset(0, 3) = Date + 30
End If Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range(xRgAddress)) If (Not xRg Is Nothing) Then
For Each xCell In xRg xCell.Offset(0, 1) = Date + 90
xCell.Offset(0, 2) = Date + 60 xCell.Offset(0, 3) = Date + 30
Next End If
Application.EnableEvents = True End If
End Sub
HI - new to VBA - I want to loop the code - VBA code: auto populate current date in a cell when the adjacent cell is updated so that after a cell is updated with a date, then move on to say "J:J" and update K with date and then do 2 more times. Not sure if it is a loop or for? Thank you
Can anyone one suggest a code for when I input number in column A and Column B and in Column C I kept a formula like Column A + Column B. Now I need a vba code that can give time and date in Column D whenever Column C changes not when inserting numbers in Column A and B.
Good Day,
Any question about Excel, please don’t hesitate to post in our forum: https://www.extendoffice.com/forum.html.
You will get more supports about Excel from our Excel professional.
Are you able to use this function twice on the same sheet? i.e. if I would like to make entries in column B to time stamp column A AND put entries in column D to timestamp column C. Thanks!
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Extendoffice 2017/10/12 Dim xRg As Range, xCell As Range
On Error Resume Next If (Target.Count = 1) Then
If (Not Application.Intersect(Target, Me.Range("B:B")) Is Nothing) Then _ Target.Offset(0, -1) = Date
Application.EnableEvents = False Set xRg = Application.Intersect(Target.Dependents, Me.Range("B:B"))
If (Not xRg Is Nothing) Then For Each xCell In xRg
xCell.Offset(0, -1) = Date Next
End If Application.EnableEvents = True
End If
On Error Resume Next
If (Target.Count = 1) Then If (Not Application.Intersect(Target, Me.Range("D:D")) Is Nothing) Then _
Target.Offset(0, -1) = Date Application.EnableEvents = False
Set xRg = Application.Intersect(Target.Dependents, Me.Range("D:D")) If (Not xRg Is Nothing) Then
For Each xCell In xRg xCell.Offset(0, -1) = Date
Next End If
Application.EnableEvents = True End If
End Sub
Thanks it works fine, but when it comes to close and save I'm getting a error that the feature "VB project" cannot be saved in a macro-free workbook. Please advise
Thanks it works fine, but when it comes to close and save I'm getting a error that the feature "VB project" cannot be saved in a macro-free workbook. Please advise
I have a set of excel worksheets titled monday, tuesday, wednesday, etc. I need to put the beginning date on Monday in cell a1, and have it fill in the subsequent dates for tuesday through Friday in cell a1 on each of those sheets. I am not code literate at all, so I just need to know what the simple formula I can put in there is. :) thank you!
