Přejít k hlavnímu obsahu

Jak automaticky vyplnit datum v buňce, když je sousední buňka aktualizována v aplikaci Excel?

Někdy můžete při aktualizaci buňky v určitém sloupci označit poslední datum aktualizace. Tento článek doporučí metodu VBA k vyřešení tohoto problému. Když se buňka aktualizuje, sousední buňka se automaticky vyplní aktuálním datem okamžitě.

Automatické vyplnění aktuálního data v buňce, když je sousední buňka aktualizována kódem VBA


Automatické vyplnění aktuálního data v buňce, když je sousední buňka aktualizována kódem VBA

Předpokládejme, že data, která potřebujete aktualizovat, se nacházejí ve sloupci B, a když se aktualizuje buňka ve sloupci B, aktuální datum se vyplní v sousední buňce sloupce A. Viz screenshot:

Chcete-li tento problém vyřešit, můžete spustit následující kód VBA.

1. Klikněte pravým tlačítkem na záložku listu, kterou chcete automaticky vyplnit na základě sousední aktualizované buňky, a poté klikněte Zobrazit kód z nabídky pravého tlačítka myši.

2. V okně Microsoft Visual Basic pro aplikace zkopírujte a vložte níže uvedený kód VBA do okna Kód.

Kód VBA: automatické vyplnění aktuálního data v buňce při aktualizaci sousední buňky

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

Poznámky:

1). V kódu B: B znamená, že se aktualizovaná data nacházejí ve sloupci B.
2). -1 označuje, že aktuální datum bude vyplněno v levém sloupci ve sloupci B. Pokud chcete, aby se aktuální datum naplnilo ve sloupci C, změňte -1 na 1.

3. lis Další + Q současně zavřete Microsoft Visual Basic pro aplikace okno.

Od této chvíle se při aktualizaci buněk ve sloupci B vyplní sousední buňka ve sloupci A aktuálním datem okamžitě. Viz screenshot:


Související články:

Nejlepší nástroje pro produktivitu v kanceláři

Populární funkce: Najít, zvýraznit nebo identifikovat duplikáty   |  Odstranit prázdné řádky   |  Kombinujte sloupce nebo buňky bez ztráty dat   |   Kolo bez vzorce ...
Super vyhledávání: Více kritérií VLookup    VLookup s více hodnotami  |   VLookup na více listech   |   Fuzzy vyhledávání ....
Pokročilý rozevírací seznam: Rychle vytvořte rozevírací seznam   |  Závislý rozbalovací seznam   |  Vícenásobný výběr rozevíracího seznamu ....
Správce sloupců: Přidejte konkrétní počet sloupců  |  Přesunout sloupce  |  Přepnout stav viditelnosti skrytých sloupců  |  Porovnejte rozsahy a sloupce ...
Doporučené funkce: Zaměření mřížky   |  Návrhové zobrazení   |   Velký Formula Bar    Správce sešitů a listů   |  Knihovna zdrojů (Automatický text)   |  Výběr data   |  Zkombinujte pracovní listy   |  Šifrovat/dešifrovat buňky    Odesílat e-maily podle seznamu   |  Super filtr   |   Speciální filtr (filtr tučné/kurzíva/přeškrtnuté...) ...
Top 15 sad nástrojů12 Text Tools (doplnit text, Odebrat znaky, ...)   |   50+ Graf Typ nemovitosti (Ganttův diagram, ...)   |   40+ Praktické Vzorce (Vypočítejte věk na základě narozenin, ...)   |   19 Vložení Tools (Vložte QR kód, Vložit obrázek z cesty, ...)   |   12 Konverze Tools (Čísla na slova, Přepočet měny, ...)   |   7 Sloučit a rozdělit Tools (Pokročilé kombinování řádků, Rozdělit buňky, ...)   |   ... a více

Rozšiřte své dovednosti Excel pomocí Kutools pro Excel a zažijte efektivitu jako nikdy předtím. Kutools for Excel nabízí více než 300 pokročilých funkcí pro zvýšení produktivity a úsporu času.  Kliknutím sem získáte funkci, kterou nejvíce potřebujete...

karta kte 201905


Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!
Comments (51)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Hello,
but what IF i want to Change more than value in column B. I Have data From A to L and I want if anyone make changes than in M and N the user and date will automatedly be adedd? Can you help with that?
This comment was minimized by the moderator on the site
This is working great but is there a way to make it so it only prefills the date if the date cell was empty?

For instance, when somebody goes back and updates the cell which triggers the date to be populated, it updates the old date to today's. I'm trying to make it so it only runs if the date cell is blank.

Thanks!
This comment was minimized by the moderator on the site
Hi Tim,
The following VBA code can help you solve this problem. The current date will only be added to cells in column A if the cell is empty when an update to the corresponding cell in column B is made.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20230721
    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
            If Target.Offset(0, -1).Value = "" Then
                Target.Offset(0, -1).Value = Date
            End If
        End If
        Application.EnableEvents = False
        Set xRg = Application.Intersect(Target.Dependents, Me.Range("B:B"))
        If (Not xRg Is Nothing) Then
            For Each xCell In xRg
                If xCell.Offset(0, -1).Value = "" Then
                    xCell.Offset(0, -1).Value = Date
                End If
            Next
        End If
        Application.EnableEvents = True
    End If
End Sub
This comment was minimized by the moderator on the site
Hi, Crystal.

This code works perfectly for me with modifications, however, I want to clear the cell if I clear the target. For example, Target Cells change, date and User name populates. GREAT!

BUT, Target Cell is cleared (deleted, " ", or changed to blank) then date and username clears.

Any Ideas?

Here is my current code that works (half way);

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
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, 3) = Environ("USERNAME")

If (Not Application.Intersect(Target, Me.Range("B:B")) Is Nothing) Then _
Target.Offset(0, 4) = 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, 3) = Environ("USERNAME")
xCell.Offset(0, 4) = Date
Next
End If
Application.EnableEvents = True

End If

End Sub
This comment was minimized by the moderator on the site
Hi Leaven Phillips,
The following VBA code can help you solve the problem. Please give it try.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Updated by Extendoffice 2023/4/14
    Dim xRg As Range, xCell As Range
    On Error Resume Next

    If Target.Count = 1 Then
        If Not Intersect(Target, Me.Range("B:B")) Is Nothing Then
            If Target.Value = "" Then ' Check if cell in column B is cleared
                Target.Offset(0, 3).ClearContents ' Clear contents of column E
                Target.Offset(0, 4).ClearContents ' Clear contents of column F
            Else ' If cell in column B is not cleared
                Target.Offset(0, 3) = Environ("USERNAME") ' Write username to column E
                Target.Offset(0, 4) = Date ' Write current date to column F
            End If
        End If
        
        Application.EnableEvents = False
        Set xRg = Application.Intersect(Target.Dependents, Me.Range("B:B"))
        
        If Not xRg Is Nothing Then
            For Each xCell In xRg
                If xCell.Offset(0, -3).Value = "" Then ' Check if cell in column B is cleared
                    xCell.Offset(0, 3).ClearContents ' Clear contents of column E
                    xCell.Offset(0, 4).ClearContents ' Clear contents of column F
                Else ' If cell in column B is not cleared
                    xCell.Offset(0, 3) = Environ("USERNAME") ' Write username to column E
                    xCell.Offset(0, 4) = Date ' Write current date to column F
                End If
            Next
        End If
        
        Application.EnableEvents = True
    End If
End Sub
This comment was minimized by the moderator on the site
Hi, I'm looking for a time stamp in F2 when a specific status is input into E2, and have G2 time stamped when E2 is updated to new specific status has been entered but not change the time stamp in F2. Is that possible?

Thank you!
This comment was minimized by the moderator on the site
Hi Alexis,
I don't quite understand your question.
What are the two specific status you mentioned above?Do you mean that when a specific value (for example A) is entered in E2, a timestamp is inserted in F2? When another specific value (for example B) is entered in E2, a timestamp is inserted in G2? If you enter a value other than the two specified values in E2, there is no change.
Can you upload a screenshot of your data?
This comment was minimized by the moderator on the site
Example.. I send an email to my boss to get approval on a project. I input that info into my sheet on E2, the time stamp for that status would be on F2. Next day my boss approves project and I update status from pending approval to approved in cell E2. Once its been updated I would like a new time stamp from that input onto G2. Is that possible?

Thank you
This comment was minimized by the moderator on the site
Hi Alexis,
The following VBA code can do you a favor. Please give it a try. Thank you.
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221028
 Dim xRg As Range
    On Error Resume Next
    If Target.Cells.Count > 1 Then
        Exit Sub
    End If
    Set xRg = Intersect(Range("E2"), Target)
    If xRg Is Nothing Then
        Exit Sub
    End If
    If Target.Value = "panding approval" Then
        Target.Offset(0, 1) = Date
        Application.EnableEvents = False
    ElseIf Target.Value = "approved" Then
        Target.Offset(0, 2) = Date
    End If
    Application.EnableEvents = True
End Sub
This comment was minimized by the moderator on the site
Hi Crystal,

I copied this to the sheet and it didn't create the times. Do I need to have the formula in the cells before I can add the code? It wont let me paste the shot of the sheet..
This comment was minimized by the moderator on the site
Hi Alexis,
Right click the sheet tab, select View Code from the right-clicking menu and copy the code into the Sheet (Code) window. Save the code and press the Alt + Q keys to close the Microsoft Visual Basic for Applications window.
When you enter "panding approval" in E2, the current time will be automatically entered in F2, and when you enter "approved" in E2, the current time will be automatically entered in G2.
This comment was minimized by the moderator on the site
Hi Dlnh,
The following VBA code can do you a favor. Please give it a try. Hope I can help.
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2022/6/10
    On Error Resume Next
    
    If Target.Count > 1 Then Exit Sub
    If Application.Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    If Target.Value = "yes" Then
        Target.Offset(0, 1) = Date
    End If
End Sub
This comment was minimized by the moderator on the site
Dear,
please help if is there a way to auto input the date to column B once the specific data input to in column A ? for a sample if I put "yes" to a cell in column A, the date will be inputted to column B and if I put " No", it won't be changed in Column B
This comment was minimized by the moderator on the site
Hi Dlnh,
The following VBA code can do you a favor. Please give it a try. Hope I can help.
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2022/6/10
    On Error Resume Next
    
    If Target.Count > 1 Then Exit Sub
    If Application.Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    If Target.Value = "yes" Then
        Target.Offset(0, 1) = Date
    End If
End Sub
This comment was minimized by the moderator on the site
Hi is there a way to modify the code such that when I copy and paste values into column B, column A still auto-populates through VBA?

Also, when I delete data in a row in column B, the date still shows in column A. How do I modify the formula such that if column B is empty in the same row, then the date will also disappear when data is deleted, rather than having to manually delete it. Many thanks!
This comment was minimized by the moderator on the site
Hello, this formula works great.  However, is there a way to set it that it only updates the cell in column A if it is empty?  
This comment was minimized by the moderator on the site
Hi Matt,Sorry, I don't quite understand what you mean. Can you try to be more specific about your question, or provide a screenshot of what you are trying to do?
This comment was minimized by the moderator on the site
Hi, I am using your code as a reference. I want to ask if it is possible to have the following:1. Prevent duplicated date entries2. Have the 2 macro inputs at the same time : Target.Offset(0,-1), Target,Offset(0,1)3. Possible to auto insert an image to the cell?
Was trying to figure it out myself but i can't seem to find any resources online which can help me
This comment was minimized by the moderator on the site
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.
This comment was minimized by the moderator on the site
Hi chapo,Try the below code. Hope I can help.<div data-tag="code">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
There are no comments posted here yet
Load More
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations