Listedeki günün ilk saati ve son saatini alma

Katılım
12 Kasım 2009
Mesajlar
78
Beğeniler
2
Excel Vers. ve Dili
2016
Türkçe
#1
Merhabalar,
Şirkette kullandığımız giriş-çıkış sistemini saat hesaplamak için kullanıyoruz ancak bazen personel gün içinde birden fazla giriş-çıkış yaptığında excel'de hesaplamak zorlaşıyor ve elle düzeltmek zorunda kalıyoruz. Yapmaya çalışıp beceremediğim şey;
1) Listedeki her güne ait ilk giriş saatini ve son çıkış saatini farklı bir alanda alt alta kopyalama,
2) Listedeki her güne ait giriş yada çıkış saati yoksa kırmızı ile işaretlenmesi,

http://s2.dosya.tc/server8/kbxctn/excel_sorun.xlsx.html
 
Katılım
9 Mart 2005
Mesajlar
2,555
Beğeniler
130
Excel Vers. ve Dili
Excel 2003-tr
#2
Kod:
Sub raporla()
    strcon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & _
             "';Extended Properties=""Excel 12.0;HDR=YES"";"

    Set RS = CreateObject("Adodb.RecordSet")

    Sheets("RAPOR").Cells.ClearContents

    STRSQL = "SELECT personel, cdate(Format(zaman,'Short Date')) AS tarih, " & _
             "First(IIf(GC='TURNIKE GIRIS',ZAMAN, NULL)) AS giris, Last(IIf(GC='TURNIKE CIKIS',ZAMAN, NULL)) AS cikis, " & _
             "iif((NOT ISNULL(cikis) AND NOT ISNULL(giris)) ,cikis-giris, null) as sure " & _
             "FROM [DATA$] GROUP BY personel, cdate(Format(zaman,'Short Date')) ORDER BY PERSONEL, Cdate(Format(zaman,'Short Date'))"

    RS.Open STRSQL, strcon

    With Sheets("RAPOR")
        .Cells.ClearContents
        .Range("A1").Resize(, 5).Value = Array("PERSONEL", "TARİH", "GİRİŞ", "ÇIKIŞ", "SÜRE")
        .Range("A2").CopyFromRecordset RS
        .UsedRange.Columns("C:D").NumberFormat = "dd/mm/yyyy hh:mm:ss"
        .UsedRange.Columns("E:E").NumberFormat = "hh:mm:ss"
        .Columns.AutoFit
    End With
    RS.Close

    Set RS = Nothing
    Application.Speech.Speak "OK"
End Sub
Kod:
Sub test()
    Dim ky As String
    [E:F].ClearContents
    ver = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row).Value
    say = -1
    ReDim lst(1 To UBound(ver) * 2, 1 To 3) As Variant
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbBinaryCompare
        For i = LBound(ver) To UBound(ver)
            ky = Trim(ver(i, 1) & "|" & Format(ver(i, 3), "dd.mm.yy"))
            If Not .Exists(ky) Then
                say = say + 2
                .Item(ky) = say
                lst(say, 1) = ver(i, 1)
                lst(say + 1, 1) = ver(i, 1)
                lst(say, 2) = "TURNIKE GIRIS"
                lst(say + 1, 2) = "TURNIKE CIKIS"
                If ver(i, 2) = "TURNIKE GIRIS" Then
                    lst(say, 3) = ver(i, 3)
                Else
                    lst(say + 1, 3) = ver(i, 3)
                End If
            Else
                If ver(i, 2) = "TURNIKE CIKIS" Then
                    sira = .Item(ky)
                    lst(sira + 1, 3) = ver(i, 3)
                End If
            End If
        Next i
        Range("D:F").Clear
        Range("D2:F2").Resize(say + 1).Value = lst
        With Range("F2:D" & say + 2)
            If WorksheetFunction.CountBlank(.Cells) > 0 Then
                .NumberFormat = "dd.mm.yyyy hh.mm.ss"
                With .SpecialCells(xlCellTypeBlanks)
                    .Interior.Color = vbRed
                    .FormulaR1C1 = "=TEXT(R[-1]C,""gg.aa.yyyy"")"
                    .Value = .Value
                End With
            End If
        End With
    End With
End Sub
Adoyla çözüm
 
Son düzenleme:
Katılım
29 Haziran 2018
Mesajlar
154
Beğeniler
33
Excel Vers. ve Dili
Excel 2013 Türkçe
#3
Bir çalışma da ben yapmıştım.
Gönder düğmesine basacakken mesaj atıldı uyarısını gördüm. . Alternatif olarak bu dosyaya da bakabilirsiniz. (Kodlama optimize değil biraz derme çatma. Ama yine de çalışıyor. )
Yalnız kodlar başka yere kopyalama yerine, olduğu yerde işlem görmeyecek satırları silerek ayıklama yapıyor. :)

Örnek Dosya


Ek: Sonradan farkettim. Kodlarda personel çıkışı yoksa farklı renkle işlem yapıyor ama, personel girişi yoksa onunla ilgili işlem yapmamışım. Düzenleme yapınca yeni dosyayı eklerim.
 
Katılım
12 Kasım 2009
Mesajlar
78
Beğeniler
2
Excel Vers. ve Dili
2016
Türkçe
#4
Merhaba,
Emeğinize teşekkür ederim çok güzel olmuş, sadece bir şey daha istemem mümkün mü acaba?
Örnek excel'de sadece 1 personeli örnek alarak listelemiştim ancak 16200 satırlık bir excel'de biraz zaman alıyor bunu yapmak.
Acaba listeden bir kişiyi filtreleyerek (Örnek: ABAŞ, MURAT) sadece filtrelenen kişiye bu makroyu uygulayabilir miyiz?

http://www.dosya.tc/server17/7gn7rk/excel_sorun2.zip.html


Bir çalışma da ben yapmıştım.
Gönder düğmesine basacakken mesaj atıldı uyarısını gördüm. . Alternatif olarak bu dosyaya da bakabilirsiniz. (Kodlama optimize değil biraz derme çatma. Ama yine de çalışıyor. )
Yalnız kodlar başka yere kopyalama yerine, olduğu yerde işlem görmeyecek satırları silerek ayıklama yapıyor. :)

Örnek Dosya


Ek: Sonradan farkettim. Kodlarda personel çıkışı yoksa farklı renkle işlem yapıyor ama, personel girişi yoksa onunla ilgili işlem yapmamışım. Düzenleme yapınca yeni dosyayı eklerim.
 
Katılım
29 Haziran 2018
Mesajlar
154
Beğeniler
33
Excel Vers. ve Dili
Excel 2013 Türkçe
#5
Rica ederim. Biraz çalışma yaptım. İnşallah olmuştur.

Giriş ve çıkış eksiklikleri için iki farklı renk ayarladım.
Ayrıca tarih alanına giriş ve çıkış için ilgili günün tarihini yazdırdım. Eğer rekler aynı olsun ve tarih yazmasın boş kalsın derseniz ona göre de işlem yapabilirim. :)

Örnek Dosya
 
Katılım
29 Haziran 2018
Mesajlar
154
Beğeniler
33
Excel Vers. ve Dili
Excel 2013 Türkçe
#7
Rica ederim. Listeye filtre uygulayıp, sonra makroyu çalıştırırsanız sorun çıkmaması lazım.
 
Katılım
12 Kasım 2009
Mesajlar
78
Beğeniler
2
Excel Vers. ve Dili
2016
Türkçe
#8
Denedim, hatta filtreyi kaldırıp tekrar uyguladım ancak hata veriyor. En son attığım linkteki dosyadan örnek görebilirsiniz.
 
Katılım
29 Haziran 2018
Mesajlar
154
Beğeniler
33
Excel Vers. ve Dili
Excel 2013 Türkçe
#9
Az önce dosyanızı indirip denedim. Hiçbir hata vermeden işlem yapabildim.
Farklı farklı kişiler seçtim, hiçbirinde hata vermedi. Sizin bilgisayarınızda hata vermesi ilginç..
 
Katılım
12 Kasım 2009
Mesajlar
78
Beğeniler
2
Excel Vers. ve Dili
2016
Türkçe
#10
Evet, sizin yüklediğiniz dosya çalışıyor ancak benim yüklediğim dosya çalışmıyor. Şimdi başka pcde deneyip bilgi vereceğim.
 
Katılım
29 Haziran 2018
Mesajlar
154
Beğeniler
33
Excel Vers. ve Dili
Excel 2013 Türkçe
#12
Hatayı buldum. Liste haricinde bir hücre seçili ise, o hücrede filtre aktif olmadığı için hata veriyor.

Makronun en başına Range("A1").Select kodunu kopyalayın sorun çözülecektir. ;)

Kod:
Sub hesapla()

Range("A1").Select
 
Son düzenleme:
Katılım
12 Kasım 2009
Mesajlar
78
Beğeniler
2
Excel Vers. ve Dili
2016
Türkçe
#13
Teşekkür ederim bu sefer oldu, son bir sorunum kaldı çözemediğim, hem A1 hemde C1'de filtre varken uyguladığımda tüm listeye uyguluyor.. Range("A1:C1").Select şeklinde yaptım ama olmadı, nasıl yapmam gerekiyor?
 
Katılım
29 Haziran 2018
Mesajlar
154
Beğeniler
33
Excel Vers. ve Dili
Excel 2013 Türkçe
#14
Makrodaki bu satırı silip. "sonhcr = Cells(Rows.Count, 1).End(xlUp).Row"

Aynı yere, aşağıdaki kodları eklerseniz sorun çözülür.

Kod:
  For Each son In Range("A2:A" & Range("A1048576").End(3).Row).SpecialCells(11)

        sonhcr = son.Row

        Exit For
  Next
 
Üst