GİRİŞ ÇIKIŞLARI MAKRO İLE DÜZENLEME

[ayşe006]

merhaba arkadaşlar aşağıdaki makro kodlarını birkaç dosya için hazırlanmış olarak buldum ama çok fazla bilmediğimden dolayı dosyamı ayacağım. istediğim listemdeki kişiler(asıl veri 100 kişilik) çok fazla giriş çıkış yaptıkları için aynı gün için ilk giriş saatti ve son çıkış saati olarak versin istiyorum yardımcı olur musunuz? excel 2010






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").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
Code:
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" & 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