ADO Nesnesi Saat Farkı ile İşlem

[yusuf1284]

33 bin satırlık veri var bu işlem doğru sonucu veriyor fakat işlem uzun sürüyor işlemi tamamıyla ADO ile yapabilir miyiz?
İl merkezinden çıkış yapıp 1 saat içerisinde dönen araçların listesi gerekiyor

Plaka	Tarih	Saat	PTS Nokta Adı	Araç Tip	Araç Yıl	Araç Marka	Araç Renk
OKUNAMADI	18.06.2023​	23:59:58	…. İl Merkezi Çıkış 2-KAMERA \ PTS
xxxxx	18.06.2023​	11:59:58	…. İl Merkezi Çıkış 1-KAMERA \ PTS	OTOMOBİL-AF Çok amaçlı	2013	TOYOTA	BEYAZ (Kar)
yyyyyy	18.06.2023​	00:32:34	…. İl Merkezi Giriş1-KAMERA \ PTS	OTOMOBİL-AA Sedan	2014	VOLKSWAGEN	BEYAZ
zzzzz	18.06.2023​	09:40:55	…. İl Merkezi Giriş1-KAMERA \ PTS	OTOMOBİL-AA Sedan	2017	FIAT	BEYAZ

Sub saatFarki()
    'Worksheets("test").Cells.Clear
    sh_sonuc.Cells.Delete 'HÜCRELERİN TAMAMINI TEMİZLE
  
     'connection nesne tanımı
    Dim con As Object, rs As Object
    Dim lastRow As Long
    Dim x As String
    'değişken tanımlama
    Dim query As String, ConStr As String, db_file As String
    Dim i As Long, j As Long
    Dim plakalar() As Variant
    Dim plaka As Variant
    Dim cikisSaat As Integer, girisSaat As Integer, saatFarki As Integer
  
    'bağlantı dizesi ifadesinin string türünden tanımı

    Set con = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
  
    On Error Resume Next
    con.Close
    rs.Close
  
    saatFarki = InputBox("Saat farkını girin:") ' Kullanıcıdan saat farkını alın
  
    'dosya konumu belirleme
    'db_file = ThisWorkbook.path & "\FoodSales.xlsx"
    db_file = ThisWorkbook.FullName
  
    'bağlantı dizesi için gerekli olan ifadenin değişkene aktarılması. (buradaki db_file özelliğini kendi veri yolunuza göre düzenleyebilirsiniz
    con.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
    db_file & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
  

  
  
    ''tüm verileri getir
    'query = "SELECT * FROM [ArsivBilgi$A1:H]"
    query = "SELECT distinct Plaka FROM [ArsivBilgi$A1:H]"
  
    'query = "SELECT * FROM [ArsivBilgi$] WHERE [Nokta Adı] = 'İl Merkezi Çıkış 2-KAMERA \ PTS' " 'AND [Tarih] = #" & Format(Date, "yyyy-mm-dd") & "# AND [Saat] >= #" & Format(TimeValue("08:00:00 AM"), "hh:mm:ss") & "# AND [Saat] <= #" & Format(TimeValue("09:00:00 AM"), "hh:mm:ss") & "# AND [Plaka] IN (SELECT [Plaka] FROM [Sayfa1$] WHERE [Nokta Adı] = 'İl Merkezi Giriş 2-KAMERA \ PTS' AND [Tarih] = #" & Format(Date, "yyyy-mm-dd") & "# AND [Saat] >= #" & Format(TimeValue("08:00:00 AM"), "hh:mm:ss") & "# AND [Saat] <= #" & Format(TimeValue("09:00:00 AM"), "hh:mm:ss") & "#)"
    'query = "SELECT * FROM [ArsivBilgi$]" & _
        "WHERE [PTS Nokta Adı] = 'Akbelen-Gözne İl Merkezi Çıkış 2-KAMERA \ PTS' AND [Saat] >= #" & Format(TimeValue("08:00:00 AM"), "hh:mm:ss") & "# AND [Saat] <= #" & Format(TimeValue("09:00:00 AM"), "hh:mm:ss") & "#"
    'query = "SELECT * FROM [ArsivBilgi$] WHERE [PTS Nokta Adı] = 'Akbelen-Gözne İl Merkezi Çıkış 2-KAMERA \ PTS' AND DATEDIFF('h', [Saat], (SELECT MIN([Saat]) FROM [ArsivBilgi$] AS sub WHERE sub.[PTS Nokta Adı] = 'Akbelen-Gözne İl Merkezi Çıkış 2-KAMERA \ PTS' AND sub.[Tarih] = [ArsivBilgi$].[Tarih])) = 1"

    rs.Open query, con, 3, 1
    'Set rs = con.Execute(query)
    ' Plakaları diziye aktar
    If Not rs.EOF Then
        rs.MoveFirst
        plakalar = rs.GetRows
    Else
        ' Sonuç yok
        Exit Sub
    End If
    rs.Close
  
    ' Her plaka için ayrı sorgular yap
For i = LBound(plakalar, 2) To UBound(plakalar, 2)
    plaka = plakalar(0, i)
  
    ' Ayrı sorgu için plaka değerini kullan
    query = "SELECT * FROM [ArsivBilgi$A1:H] WHERE [Plaka] = '" & plaka & "' AND [PTS Nokta Adı] Like '%Çıkış%' "
    query = "SELECT * FROM [ArsivBilgi$A1:H] WHERE [Plaka] = '" & plaka & "' "

    'AND [Tarih] = #" & Format(Date, "yyyy-mm-dd") & "# AND [Saat] >= #" & Format(TimeValue("08:00:00 AM"), "hh:mm:ss") & "# AND [Saat] <= #" & Format(TimeValue("09:00:00 AM"), "hh:mm:ss") & "#"
  
    ' Ayrı sorguyu çalıştır
    rs.Open query, con, 3, 1
    cikisSaat = 0
    girisSaat = 0
    ' Sonuçları işleme
    If Not rs.EOF Then
        rs.MoveFirst
        Do Until rs.EOF
            ' Sonuçları kullanarak istediğiniz işlemleri yapabilirsiniz
            ' Örneğin:
          
            'If rs.Fields("PTS Nokta Adı").Value Like "%Çıkış%" Then
            If InStr(1, rs.Fields("PTS Nokta Adı").Value, "Çıkış") > 0 Then 'EĞER Çıkış KELİMESİ VARSA
                cikisSaat = Format(rs.Fields("Saat").Value, "HH")
            End If
            If InStr(1, rs.Fields("PTS Nokta Adı").Value, "Giriş") > 0 Then 'EĞER Çıkış KELİMESİ VARSA
                girisSaat = Format(rs.Fields("Saat").Value, "HH")
            End If
          
            If cikisSaat - girisSaat = saatFarki Then
                rs.Close
                query = "SELECT * FROM [ArsivBilgi$A1:H] WHERE [Plaka] = '" & plaka & "' "
                rs.Open query, con, 3, 1
                If sh_sonuc.Range("a1") = "" Then
                        For j = 0 To rs.Fields.Count - 1
                            sh_sonuc.Cells(1, j + 1).Value = rs.Fields(j).Name
                        Next j
                End If
                lastRow = sh_sonuc.Cells(sh_sonuc.Rows.Count, "B").End(xlUp).Row + 1
                sh_sonuc.Range("A" & lastRow).CopyFromRecordset rs
                Exit Do
            End If
          
            rs.MoveNext
        Loop

    Else
        ' Sonuç yok
    End If
  
    ' Sorguyu kapat
    rs.Close
Next i
    lastRow = sh_sonuc.Cells(sh_sonuc.Rows.Count, "B").End(xlUp).Row + 1
    sh_sonuc.Range("B2:B" & lastRow + rs.RecordCount).NumberFormat = "dd/mm/yyyy" 'Tarih formatına çevir
    sh_sonuc.Range("C2:C" & lastRow + rs.RecordCount).NumberFormat = "HH:MM" 'saat formatına çevir
    sh_sonuc.Range("A1").AutoFilter
    sh_sonuc.Cells.EntireColumn.AutoFit
  
    con.Close
  
  
    Set rs = Nothing
    Set con = Nothing
  
End Sub

 

[yusuf1284]

Başka fikri olan var mı ADO nesnesi kullanmadan da olabilir.

 

[Korhan Ayhan]

Örnek dosya paylaşırsanız yardımcı olmak isteyenlerin deneme şansı olacaktır.

Örnek dosyanızda ham veri bu şekilde görmek istediğim sonuç bu şekilde diye örneklerseniz daha faydalı olacaktır.

 

[yusuf1284]

Hocam 32 bin veri var plakaları sallama şansım olmadığında tablo benzerini konu içerisine eklemiştim

 

[Korhan Ayhan]

Örnek dosya talep ettiğimizde neden üyelerimiz asıl dosyalarını paylaşma ihtiyacı hissediyorlar anlamıyorum..

Adı üzerinde ÖRNEK DOSYA...

Örnek dosyanızın içinde düzeni anlayabilmek adına maksimum 50 satır olması yeterlidir.

 

[yusuf1284]

Haklısınız Hocam plakaların başını değiştirdim bakabilir misiniz? @Korhan Ayhan

 

[yusuf1284]

Hocam bakma şansınız oldu mu @Korhan Ayhan

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Time_Difference_Report()
    Dim S1 As Worksheet, S2 As Worksheet, Hour_Difference As Double
    Dim My_Data As Variant, X As Long, Y As Long, No As Long
    Dim Vehicle_Exit As Object, Process_Time As Double
    Dim My_Connection As Object, My_Recordset As Object
    Dim Hour_Difference_Input As Variant
   
    Hour_Difference_Input = Application.InputBox("Raporlamak istediğiniz saat farkını hh:mm:ss biçiminde giriniz...", "SAAT FARKI GİRİŞİ", "01:00:00")
    
    If Hour_Difference_Input = False Then
        MsgBox "İşleminiz iptal edilmiştir!", vbCritical
        Exit Sub
    End If
    
    If Hour_Difference_Input = "" Then
        MsgBox "Saat farkı değerini girmediğiniz için işleminiz iptal edilmiştir!", vbCritical
        Exit Sub
    End If
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("ArsivBilgi")
    Set S2 = Sheets("Sonuc")
    Set Vehicle_Exit = VBA.CreateObject("Scripting.Dictionary")
    Set My_Connection = CreateObject("AdoDB.Connection")
   
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    S2.Range("A:E").Clear
    S2.Range("A1:E1") = Array("PLAKA", "TARİH", "ÇIKIŞ SAATİ", "GİRİŞ SAATİ", "SAAT FARKI")
    S2.Range("A1:E1").Font.Bold = True
    S2.Range("A1:E1").HorizontalAlignment = xlCenter
    On Error GoTo 0
    
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
   
    Set My_Recordset = My_Connection.Execute("Select * From [" & S1.Name & "$A2:H] Order By F1,F2,F3 Asc")
    
    My_Data = My_Recordset.GetRows
    
    My_Recordset.Close
    My_Connection.Close
    
    ReDim My_List(1 To UBound(My_Data, 2), 1 To 5)
    
    For X = LBound(My_Data, 2) To UBound(My_Data, 2)
        If My_Data(3, X) Like "*Çıkış*" Then
            Vehicle_Exit.Add My_Data(0, X), My_Data(1, X) + My_Data(2, X)
            For Y = X + 1 To UBound(My_Data, 2)
                If My_Data(3, Y) Like "*Giriş*" Then
                    If Vehicle_Exit.Exists(My_Data(0, Y)) Then
                        Hour_Difference = (My_Data(1, Y) + My_Data(2, Y)) - Vehicle_Exit.Item(My_Data(0, X))
                        If Hour_Difference <= TimeValue(Hour_Difference_Input) Then
                            No = No + 1
                            My_List(No, 1) = My_Data(0, X)
                            My_List(No, 2) = My_Data(1, X)
                            My_List(No, 3) = Format(My_Data(2, Y), "hh:mm:ss")
                            My_List(No, 4) = Format(My_Data(2, X), "hh:mm:ss")
                            My_List(No, 5) = Format(Hour_Difference, "hh:mm:ss")
                            Vehicle_Exit.Remove My_Data(0, X)
                            X = Y
                            Exit For
                        Else
                            Vehicle_Exit.Remove My_Data(0, X)
                            X = Y
                            Exit For
                        End If
                    Else
                        X = Y
                        Exit For
                    End If
                Else
                    Vehicle_Exit.Remove My_Data(0, X)
                    X = Y - 1
                    Exit For
                End If
            Next
        End If
    Next
    
    S2.Range("A2").Resize(No, UBound(My_List, 2)) = My_List
    S2.Range("A:E").AutoFilter
    S2.Columns.AutoFit
    
    Erase My_Data
    Erase My_List
    Vehicle_Exit.RemoveAll
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Vehicle_Exit = Nothing
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[dost]

Merhaba,

Alternatif olsun.

NOT: Sadece çıkış olan yada sadece giriş olanlar dikkate alınmamıştır. Birden fazla giriş çıkışı olanların en son giriş ve çıkışları dikkate alınmıştır.

Sub Test()
    Dim conn As Object
    Dim rs As Object
    Dim strSQL As String
    Dim SaatFarki As Integer
   
    Application.ScreenUpdating = False
   
    SaatFarki = Application.InputBox("Saat farkını girin:", Type:=1)
   
    If SaatFarki = False Then MsgBox "İşlem iptal":  Exit Sub
   
    Sheets("Sonuc").UsedRange.ClearContents
   
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;"""
             
    strSQL = "SELECT [Plaka], MAX(IIF([PTS Nokta Adı] LIKE '%Giriş%', Format([Saat], ""HH:MM""), NULL)) AS GirisTarihi, " & _
             "MAX(IIF([PTS Nokta Adı] LIKE '%Çıkış%', Format([Saat], ""HH:MM""), NULL)) AS CikisTarihi, COUNT([Plaka]) AS IslemSayisi " & _
             "FROM [ArsivBilgi$] " & _
             "WHERE [PTS Nokta Adı] LIKE '%Giriş%' OR [PTS Nokta Adı] LIKE '%Çıkış%' " & _
             "GROUP BY [Plaka] " & _
             "HAVING COUNT([Plaka]) > 1 AND SUM(IIF([PTS Nokta Adı] LIKE '%Giriş%', Format([Saat], ""HH""), -Format([Saat], ""HH""))) = " & SaatFarki & "  " & _
             "ORDER BY [Plaka] "
   
    Set rs = conn.Execute(strSQL)
    Sheets("Sonuc").Range("A1").Resize(1, 4) = Array("Plaka", "GirisTarihi", "CikisTarihi", "IslemSayisi")
    Sheets("Sonuc").Rows("1").Font.Bold = True
    Sheets("Sonuc").Range("A2").CopyFromRecordset rs
   
    rs.Close:    conn.Close
    Set rs = Nothing:    Set conn = Nothing
   
    Sheets("Sonuc").Columns.AutoFit
    MsgBox "İşlem Tamamlandı"
   
    Application.ScreenUpdating = True
   
End Sub

 

[yusuf1284]

Değerli hocalarıma ayrı ayrı çok teşekkür ederim 2 yöntemi de detaylı inceleyeceğim. Uzun zamandır çoğu şeyi araştırma ile hallettim ama yine bu siteye bağlılığım devam etti devamda edecek bu şekilde sıkıştığımda yardımlarınız çok kıymetli Allah razı olsun.