İki Listeyi Karşılaştırıp Farkları Bulma(İki Kritere Göre)

[hamitcan]

Ana listedeki(a ve b sütunları) tarih ve fiş no bilgilerini, kontrol edilen(c ve d sütunları) listedeki bilgilerle kaşılaştırıp kalan listeye(e ve f sütunları) yazmasını istiyorum ama bir türlü doğru sorguyu oluşturamadım. Yardımlarınız için şimdiden teşekkürler.

Dim baglan, kayitseti As Object

Sub sorgu()

baglanti

S = "SELECT * FROM [Sayfa1$] WHERE [Tarih] ='04/01/2011' And [Fiş No] = 1"

kayitseti.Open S, baglan
   
   If kayitseti.EOF Then
   kayitseti.Close
   baglan.Close
   Set kayitseti = Nothing
   Set baglan = Nothing
   

   Else
   MsgBox "e"


kayitseti.Close
baglan.Close
Set kayitseti = Nothing
Set baglan = Nothing

   End If
  

End Sub

Sub baglanti()
Set baglan = CreateObject("ADODB.Connection")
baglan.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"/KalanListeyiBul.xlsm;extended properties=""excel 8.0;hdr=yes"""
Set kayitseti = New ADODB.Recordset

End Sub

 

[Mehmet Şahin]

Merhaba,
kodlarda biraz değişiklik yaptım. Ancak birbiriyle eşleşen birden fazla satır var.
Onları da ayrı ayrı yazacaktır.

Dim baglan, kayitseti As Object

Sub sorgu()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sayfa1")
sn = sh.[a65536].End(3).Row
baglanti


S = "SELECT * FROM [Sayfa1$a3:b" & sn & "] "
kayitseti.Open S, baglan
sat = 3
If kayitseti.EOF = True Then GoTo son

  Do While Not kayitseti.EOF
    For i = 3 To sh.[c65536].End(3).Row
       If kayitseti("F1") = sh.Cells(i, "c") And kayitseti("F2") = sh.Cells(i, "d") Then
            sh.Cells(sat, "e") = kayitseti("F1")
            sh.Cells(sat, "f") = kayitseti("F2")
       sat = sat + 1
       End If
    Next i
  kayitseti.MoveNext
  Loop
kayitseti.Close
baglan.Close
son:
Set kayitseti = Nothing
Set baglan = Nothing
  
Set sh = Nothing
End Sub

Sub baglanti()
Set baglan = CreateObject("ADODB.Connection")
baglan.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"/KalanListeyiBul.xlsm;extended properties=""excel 8.0;hdr=yes"""
Set kayitseti = CreateObject("AdoDb.Recordset")
End Sub

 

[hamitcan]

Sayın dentex,öncelikle teşekkürler,ama kod doğru çalışmadı. Şöyle olmalı; Ana listeden kontrol edilen listedeki bilgiler düşülüp kalan listenin oluşturulması.

 

[Mehmet Şahin]

Sayın Hamitcan,
bu şekilde deneyebilirmisiniz.

Dim baglan, kayitseti As Object
Sub sorgu()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sayfa1")
sn = sh.[a65536].End(3).Row
baglanti


S = "SELECT * FROM [Sayfa1$a3:b" & sn & "] "
kayitseti.Open S, baglan, 1, 1
sat = 3
If kayitseti.EOF = True Then GoTo son

  Do While Not kayitseti.EOF
    For i = 3 To sh.[c65536].End(3).Row
       If WorksheetFunction.CountIf(sh.Range("c3:c" & sh.[c65536].End(3).Row), kayitseti("F1")) > 0 And WorksheetFunction.CountIf(sh.Range("d3:d" & sh.[d65536].End(3).Row), kayitseti("F2")) > 0 Then
       Else
            sh.Cells(sat, "e") = kayitseti("F1")
            sh.Cells(sat, "f") = kayitseti("F2")
       sat = sat + 1
       Exit For
       End If
    Next i
  kayitseti.MoveNext
  Loop
kayitseti.Close
baglan.Close
son:
Set kayitseti = Nothing
Set baglan = Nothing
  
Set sh = Nothing
End Sub

Sub baglanti()
Set baglan = CreateObject("ADODB.Connection")
baglan.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"/KalanListeyiBul.xlsm;extended properties=""excel 8.0;hdr=no""" 'değişti
Set kayitseti = CreateObject("AdoDb.Recordset")
End Sub

 

[hamitcan]

Sayın dentex, çok teşekkürler, çok güzel çalışıyor. Burada sormak istediğim bir şey var.
F1 ve F2 ifadeleri neyi ifade ediyor ?

 

[Mehmet Şahin]

Merhaba,
Bu ifadeler, Field1, Field2 gibi sütun başlıklarını belirliyor.
Saygılar, iyi çalışmalar.