< návrat zpět

MS Excel

Téma: Automatické doplnění aktuálního data rss

Zaslal/a Mercur83 28.3.2017 16:40

Dobrý den,

potřeboval by jsem pomoci s makrem, které by do prvního sloupce doplnilo aktuální datum.
Zatím se mi zkoumáním různě po netu podařilo dát dohromady následující:

Sub MacroDatum()
On Error Resume Next
If ActiveCell.Column = 2 Then
With ActiveCell.Offset(-1, -1)
.Value = Date
.NumberFormat = "[$-409]d.mm.yyyy;@"
End With
End If
End Sub

které spouštím pomocí:

Private Sub Worksheet_Change(ByVal Target As Range)
Call MacroDatum
End Sub

Toto však doplní datum pouze do buňky vlevo od druhého sloupce, pokud do buňky v druhém sloupci vepíšu hodnotu a potvrdím Entrem.
Potřeboval by jsem aby makro vepsalo aktuální datu do prvního sloupce na stejném řádku ve kterém byla vyplněna hodnota v druhém popřípadě některém z dalších sloupců. Sloupců by v tabulce nemělo být víc jak 15.
Snad jsem problém popsal dostatečně srozumitelně.
Předem velmi děkuji za odpovědi a za pomoc.

Zaslat odpověď >
elninoslov(28.3.2017 17:46)#035811
elninoslov
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B:P")) Is Nothing Then Call MacroDatum(Target)
End Sub

Sub MacroDatum(ByRef Target As Range)
Intersect(Target.EntireRow, Columns(1)).Value = Date
End Subcitovat
Mercur83(28.3.2017 19:17)#035812
avatar

elninoslov napsal/a:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B:P")) Is Nothing Then Call MacroDatum(Target)
End Sub

Sub MacroDatum(ByRef Target As Range)
Intersect(Target.EntireRow, Columns(1)).Value = Date
End Sub


Mockrát děkuji za pomoc 1citovat
Mercur83(29.3.2017 12:49)#035828
avatar
Dobrý den,

ještě bylo by možné aby se datum neaktualizovalo pokud je jednou zadané?

Předem moc díkycitovat
elninoslov(29.3.2017 14:56)#035836
elninoslov
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B:P")) Is Nothing Then Call MacroDatum(Intersect(Target.EntireRow, Columns(1)))
End Sub

Sub MacroDatum(ByRef Target As Range)
Dim RNG As Range

If Target.Cells.Count > 1 Then
On Error Resume Next
Set RNG = Target.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
Else
If IsEmpty(Target) Then Set RNG = Target
End If

If Not RNG Is Nothing Then
Application.EnableEvents = False
RNG.Value = Date: Set RNG = Nothing
Application.EnableEvents = True
End If
End Subcitovat
Mercur83(30.3.2017 8:18)#035861
avatar
Super teď už je to dokonalé ještě jednou díky moc 1citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje