saati olmayan tarih bilgisine saat bilgisi de ekleme

[FASTBULL]

Merhabalar...
Yukarıda ki resimde de gördüğünüz gibi 30 Nisan tarihine ait kayıtları aynı olacak şekilde sıraya sokmak için her bir kayda sabah 10 ile akşam 18 arasında rastgele saat bilgisi girmek istiyorum. Ama sırada ilk olan kaydın her zaman saat olarak daha erken olması lazım. Bazen düşündüğünüz şeyi ifade edemezsiniz ya şu an bende öyleyim nasıl ifade edeceğimi bilmiyorum. Aslında yaptırmak istediğim şey şu: Gidecek tarihlere bakacak aynı tarihe denk gelen kayıtları tespit edecek ve sabah saat 10 dan başlayarak her bir kayda rastgele saat bilgisi girecek. Ama sonra ki kayıt önceki kayıttan daha erken bir saat bilgisine sahip olamayacak.
Bunu istememde ki amaç senelik dosyalar mevcut. Ve marka bazında ayrılmış sheet ler var. Örnek A markası A sheet te, B markası B sheet te gibi. Ben bunların hepsini tek bir sheet te toplamak istedim ve topladım da. Ama bazı ufak tefek sorunlarla karşılaştım. Ya yeniden hazırlamam gerek ya da bu tarihlere saat bilgisi de ekleyerek düzgün bir şekilde sıralatmam gerek.
Resimde de gördüğünüz gibi kayıtların sırasında farklılıklar var. Çok fazla data var. Toplam da 5000 civarı bir şey.
Fikirlerinize çok ihtiyacım var.
Umarım anlatabilmişimdir.
Teşekkürler....

 

[PLİNT]

Merhaba
Aşağıdaki makroyu "Orjinal kayıt" sayfası aktif iken çalıştırıp deneyin.
"Orjinal kayıt" ta tarihlerin "H" sütununda, "H2" hücresinden başladığını ve satırlarda boşluk olmadığını varsayarak;

[SIZE="2"]Sub saat_ekle()
Set s1 = ActiveSheet
s1.Cells(2, "H") = DateValue(Format(Split(CDbl(CDate(s1.Cells(2, "H"))), ",")(0), _
"dd.mm.yyyy hh:mm:ss")) + TimeSerial(10, 0, 0)
For A = 3 To s1.Cells(Rows.Count, "H").End(3).Row
If DateDiff("d", s1.Cells(A - 1, "H"), s1.Cells(A, "H")) > 0 Then
s1.Cells(A, "H") = DateValue(Format(Split(CDbl(CDate(s1.Cells(A, "H"))), ",")(0), _
"dd.mm.yyyy hh:mm:ss")) + TimeSerial(10, 0, 0)
Else
s1.Cells(A, "H") = s1.Cells(A - 1, "H") + TimeSerial(0, 1, 0)
End If
Next
End Sub [/SIZE]

 

[FASTBULL]

Var ya Hızır gibi yetiştiniz. Allah razı olsun ) Çok teşekkür ederim. Beni nasıl büyük bir zahmetten kurtardınız anlatamam. Yanlız benim bu tarihler A da değil H da. Cells(2,1) yazan yerleri cells(2,8) ve A yazan yerleri de H olarak değiştirirsem gene mükemmel bir şekilde çalışır mı makro ?

 

[PLİNT]

Yukarıdaki değişen kodları deneyin

Merhaba
Aşağıdaki makroyu "Orjinal kayıt" sayfası aktif iken çalıştırıp deneyin.
"Orjinal kayıt" ta tarihlerin "H" sütununda, "H2" hücresinden başladığını ve satırlarda boşluk olmadığını varsayarak;

 

[FASTBULL]

çok teşekkür ederim

 

[FASTBULL]

Sevgili Plint
Yazdığınız makro tek sheet içinde mükemmel çalıştı. Fakat birden fazla sheette çalıştırıp ve sheet leri tek bir sheet altında toplayınca tekrardan aynı tarih değerlerine sahip bir den fazla kayıt meydana geldi. Bende sizden aldığım ilham ve biraz araştırmalarım sonucunda şöyle makro oluşturdum.
Yalnız bu makro; en sona ekstradan 2 adet satır ekliyor. Neden ekliyor çözemedim. Yardımcı olursanız sevinirim.
Saygılar...

Sub Zaman_Ekle()
Set sayfa = ActiveSheet
Dim saat
Dim yeniTarih
Dim satirAdet
Dim adet

satirAdet = sayfa.Cells(Rows.Count, "H").End(3).Row
Columns("G:G").ClearContents

Range("H2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "General"
    
For i = 2 To satirAdet
adet = WorksheetFunction.CountIf(Range("H2:H" & sayfa.Cells(Rows.Count, "H").End(3).Row), sayfa.Cells(i, "H"))
If adet = 1 Then
    Randomize
    saat = (0.7813078704 - 0.4380208333 + 0) * Rnd + 0.4380208333
    yeniTarih = sayfa.Cells(i, "H").Value + saat
    sayfa.Cells(i, "G").Value = yeniTarih
Else
    For k = i To (i + adet)
        Randomize
        saat = (0.7813078704 - 0.4380208333 + 0) * Rnd + 0.4380208333
        yeniTarih = sayfa.Cells(k, "H").Value + saat
        sayfa.Cells(k, "G").Value = yeniTarih
    Next k
    
End If
Next i

Range("G2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "dd/mm/yyyy hh:mm:ss"

End Sub

 

[PLİNT]

Merhaba
Tüm sayfaları; düzenleme yapacağımız sayfaya aldıktan sonra şöyle yapalım;

Örnek dosya

[SIZE="2"]Sub saat_ekle()
Set s1 = ActiveSheet
i = s1.Cells(Rows.Count, "H").End(3).Row
For a = 2 To i
x = 0
With s1.Range("H1:H" & i)
    Set c = .Find(DateValue(Format(s1.Cells(a, "H"), "dd.mm.yyyy")), LookIn:=xlFormulas, lookat:=xlPart)
 If s1.Range("H1:H" & a - 1).Find(DateValue(Format(s1.Cells(a, "H"), "dd.mm.yyyy")), LookIn:=xlFormulas, lookat:=xlPart) Is Nothing Then
    If Not c Is Nothing Then
        f = c.Address
        Do
       x = x + 1
s1.Cells(c.Row, "H") = DateValue(Format(Split(CDbl(CDate(s1.Cells(c.Row, "H"))), ",")(0), _
"dd.mm.yyyy hh:mm:ss")) + TimeSerial(10, 0, 0)
s1.Cells(c.Row, "H") = s1.Cells(c.Row, "H") + TimeSerial(0, 0, x)
 Set c = .FindNext(c)
If c Is Nothing Then Exit Do
        Loop While Not c Is Nothing And c.Address <> f
    End If: End If
End With
Next
s1.[H:H].NumberFormat = "d/m/yyyy h:mm:ss"
End Sub[/SIZE]

 

[FASTBULL]

Teşekkür ederim...
Elinize sağlık...