• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Tarih ve saat

ASLAN7410

ASLAN7410

Katılım
15 Temmuz 2012
Mesajlar
2,802
Excel Vers. ve Dili
Ofis 2021 TR 64 Bit
Merhaba hayırlı geceler.

Ekte gönderdiğim excel dosyamın sayfanın kod bölümünde aşağıdaki kod var, kod E ve F sütununda çift tıkladığında tarih ve saat atıyor, bu sütunlarda dolu olan hücrelerde tekrar tıklandığında tarih ve saat atmıyor, kodlar tam istediğim gibi gayet güzel çalışıyor.

Ben bu kodu Private Sub Worksheet_Change(ByVal Target As Range) bu başlık altında çalıştırmaya çalıştım ama yapamadım.

Yapmak istediğim B2 sütunundan aşağıya doğru bilgi girdiğimde C sütunundaki ilgili hücreye tarih, D sütunundaki ilgili hücreye saat atmasını ve A sütununa sıra no vermesini istiyorum istiyorum.

Yardımcı olur musunuz?

Kod: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If Not Target.Column <> 5 Then
If IsDate(Target.Value) = False Then
    Target.Value = Format(Now, "dd.mm.yyyy")
End If
End If
If Target.Column <> 6 Then Exit Sub
If IsTime(Format(Target.Value, "hh:mm")) = False Then
    Target.Value = Format(Now, "hh:mm")
End If
End Sub
Function IsTime(str)
  If str = "" Then
    IsTime = False
  Else
    On Error Resume Next
    TimeValue (str)
    If Err.Number = 0 Then
      IsTime = True
    Else
      IsTime = False
    End If
    On Error GoTo 0
  End If
End Function
 

Ekli dosyalar

Aşağıdaki şekilde deneyin. Tarih ve saat varsa işlem yapma demişsiniz.
Kod: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If Not Target.Column <> 5 Then
'If IsDate(Target.Value) = False Then
    Target.Value = Format(Now, "dd.mm.yyyy")
'End If
End If
If Target.Column <> 6 Then Exit Sub
'If IsTime(Format(Target.Value, "hh:mm")) = False Then
    Target.Value = Format(Now, "hh:mm")
'End If
End Sub
 
Sayın askm, ilginiz için çok teşekkür ediyorum, bu kodu zaten daha önceden siz göndermiştiniz, çok teşekkür ediyorum. Kodda bir sıkıntı yok zaten.

Göndermiş olduğum örnekte B2 sütunundan aşağıya doğru bilgi girdiğimde C sütunundaki ilgili hücreye tarih, D sütunundaki ilgili hücreye saat atmasını ve A sütununa sıra no vermesini istiyorum istiyorum. Bu kodun Private Sub Worksheet_Change(ByVal Target As Range) bu başlık altında bu şekilde çalışmasını istiyorum.
 
İsteğiniz aşağıdaki şekilde mi?
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
    On Error Resume Next
    If IsDate(Cells(Target.Row, "C").Value) = False Then
        Cells(Target.Row, "C").Value = Format(Now, "dd.mm.yyyy")
    End If

    If IsTime(Format(Cells(Target.Row, "C").Value, "hh:mm")) = False Then
        Cells(Target.Row, "D").Value = Format(Now, "hh:mm")
    End If

End Sub
 
Sayın askm, çok teşekkür ediyorum, ellerinize sağlık tam istediğim gibi oldu.

Hayırlı çalışmalar, hayırlı geceler diliyorum.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
With Sheets(1).Range("A2:A" & Sheets(1).[B65536].End(3).Row)
    .Formula = "=Row()-1"
    .Value = .Value
End With
    On Error Resume Next
    If IsDate(Cells(Target.Row, "C").Value) = False Then
        Cells(Target.Row, "C").Value = Format(Now, "dd.mm.yyyy")
    End If

    If IsTime(Format(Cells(Target.Row, "D").Value, "hh:mm")) = False Then
        Cells(Target.Row, "D").Value = Format(Now, "hh:mm")
    End If
End Sub
Function IsTime(str)
  If str = "" Then
    IsTime = False
  Else
    On Error Resume Next
    TimeValue (str)
    If Err.Number = 0 Then
      IsTime = True
    Else
      IsTime = False
    End If
    On Error GoTo 0
  End If
End Function
 
Son düzenleme:
Bu mesaj silindi.
 
Son düzenleme:
Sayın askm, B sütununa bilgi girildiği zaman bu kodlar gayet güzel çalışıyor, ellerinize sağlık, H sütununa da aynı şekilde ASLAN yazmasını istiyorum, bunu da ekleyebilir misiniz?
 
Belki birinin işine yarar diye ekliyorum, aşağıdaki kodlar tam istediğim gibi çalışıyor.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B2:B" & Rows.Count)) Is Nothing Then Exit Sub

    With Sheets(1).Range("A2:A" & Sheets(1).[B65536].End(3).Row)
        .Formula = "=Row()-1"
        .Value = .Value
    End With
    
    On Error Resume Next
    If IsDate(Cells(Target.Row, "C").Value) = False Then
        Cells(Target.Row, "C").Value = Format(Now, "dd.mm.yyyy")
    End If

    If IsTime(Format(Cells(Target.Row, "D").Value, "hh:mm")) = False Then
        Cells(Target.Row, "D").Value = Format(Now, "hh:mm")
    End If
    
    If Cells(Target.Row, "H").Value = False Then
        Cells(Target.Row, "H").Value = "ASLAN"
    End If
End Sub
Function IsTime(str)
  If str = "" Then
    IsTime = False
  Else
    On Error Resume Next
    TimeValue (str)
    If Err.Number = 0 Then
      IsTime = True
    Else
      IsTime = False
    End If
    On Error GoTo 0
  End If
End Function
 
selamun aleyküm bende böyle bir sorun var
mesela a1 hücresine veri girdiğimde b1 sütünuna saati atmasını istiyorum. yine aynı şekil c1 sutununa veri girdiğimde d1sütünuna saati atmasını istiyorum.e1 sutununa veri girdiğimde f1sütünuna saati atmasını istiyorum nasıl bir kod lazım yardımlarınızı bekliyorum
 
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If IsTime(Format(Target.Value, "hh:mm")) = False Then
    Cells(Target.Row, Target.Column + 1).Value = Format(Now, "hh:mm")
End If

End Sub

Function IsTime(str)
  If str = "" Then
    IsTime = False
  Else
    On Error Resume Next
    TimeValue (str)
    If Err.Number = 0 Then
      IsTime = True
    Else
      IsTime = False
    End If
    On Error GoTo 0
  End If
End Function
 
karaca1981' Alıntı:
selamun aleyküm bende böyle bir sorun var
mesela a1 hücresine veri girdiğimde b1 sütünuna saati atmasını istiyorum. yine aynı şekil c1 sutununa veri girdiğimde d1sütünuna saati atmasını istiyorum.e1 sutununa veri girdiğimde f1sütünuna saati atmasını istiyorum nasıl bir kod lazım yardımlarınızı bekliyorum
Genişletmek için tıkla ...
Buyurun.:cool:

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1,C1,E1")) Is Nothing Then Exit Sub
Target.Offset(0, 1).NumberFormat = "hh:mm:ss"
Target.Offset(0, 1).Value = Now
End Sub
 
askm ve Orion1 çok teşşekkürler rabbim razı olsun
 
abiler yaptığımız yeri yani a1 hücresini sildiğimde yana doğru hep saat atıyor otomatik olarak
 
karaca1981' Alıntı:
abiler yaptığımız yeri yani a1 hücresini sildiğimde yana doğru hep saat atıyor otomatik olarak
Genişletmek için tıkla ...
Buyurun.:cool:
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1,C1,E1")) Is Nothing Then Exit Sub
If Target.Value <> "" Then
    Target.Offset(0, 1).NumberFormat = "hh:mm:ss"
    Target.Offset(0, 1).Value = Now
End If
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst