ADODB bağlantısında İki sütunu içeren benzersizleri recordsete verme?

[hsayar]

ADODB bağlantısında İki sütunu içeren benzersizleri recordste verme nasıl olmalıdır?

veriler Data sayfasında ve ABC sütunlarının 3. satırdan başlamaktadır.
Sayaç ve Adı aynı olanlar bir kere listelenecektir.
yardımlarınız için teşekkür ederim.

  ABONENİN
Sayac_No    Adi_Soyadi    Mevkii
1542    Ahmet ER    Ayranlı
1542    Ahmet ER    Ayranlı
1542    Ahmet ER    Ayranlı
1582    Ahmet ER    Paşakaldırımı
1582    Ahmet ER    Paşakaldırımı
1583    Ahmet ER    Paşakaldırımı2
1583    Ahmet ER    Paşakaldırımı2
1452    Cemil güz    Kumdere
1542    Ahmet ER    Ayranlı
1542    Ahmet ER    Ayranlı
1542    Ahmet ER    Ayranlı
1582    Ahmet ER    Paşakaldırımı
1582    Ahmet ER    Paşakaldırımı
1583    Ahmet ER    Paşakaldırımı2
1583    Gülsüm AKIN    Paşakaldırımı2
1452    Cemil güz    Kumdere

Sub x_ozet()
'ActiveX DataObject 2.7 seçili olmalıdır.
'On Error GoTo HATALAR
Dim CKtp_Bu     As Workbook:            Set CKtp_Bu = ThisWorkbook                                                                                '||
Dim CSfData     As Worksheet:           Set CSfData = CKtp_Bu.Sheets("DATA")
Dim CSfBlnc     As Worksheet:           Set CSfBlnc = CKtp_Bu.Sheets("Ozet")
Dim BgADODB     As ADODB.Connection:    Set BgADODB = New ADODB.Connection
Dim KsADODB     As ADODB.Recordset
Dim SQLFrm$, SQLBas$, SQLSrg$, SQLStr$
                                                                
  With CSfBlnc
    .Cells.Clear
    .Activate
    .Range(Cells(1, 1), Cells(1, 3)).Value = Array("Sayac_No", "Adi_Soyadi", "Mevkii")
    BgADODB.Open "Driver={Microsoft Excel Driver (*.xls)};dbq=" & CKtp_Bu.FullName                         '||
    SQLFrm = "[" & CSfData.Name & "$A3:C18" & "]"                                                                          '||
    SQLBas = "Sayac_No, Adi_Soyadi, Mevkii"
   ' SqlSrg = "Sayaç_No = " & "'" & " AND Adı_Soyadı =  " & "'" & " AND Mevkii  =  " & "'"""
 '   SqlSrg = "Sayaç_No = " & srgYil & " AND Adı_Soyadı = " & "'" & "Personel" & "'"                 '||
 '   SqlSrg = SqlSrg & " AND MES_MER = " & "'" & "Daimi" & "'"                                   '||
     SQLStr = "SELECT DISTINCT " & SQLBas & " FROM " & SQLFrm '& " WHERE " & SqlSrg
    
    Set KsADODB = BgADODB.Execute(SQLStr)                                                         '||
      .Cells(2, "A").CopyFromRecordset KsADODB                                                     '||
    KsADODB.Close:     Set KsADODB = Nothing                                                    '||
    BgADODB.Close:     Set BgADODB = Nothing
  End With

HATALAR:
Set CKtp_Bu = Nothing                                                                                '||
Set CSfData = Nothing
Set CSfBlnc = Nothing
End Sub

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub Güncelle()
'On Error Resume Next
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO, s1 As Object
Dim SQLStr As String
Kaynak = Application.GetOpenFilename("Excel Dosyası (*.xls),*.xls", , "Hedef Dosyayı Seçiniz")
If Kaynak = False Then Exit Sub
Set s1 = Sheets("Sayfa1")
SQLStr = "SELECT DISTINCT * FROM [data$a2:c1000]"
Set Baglanti = CreateObject("ADODB.Connection")
    With Baglanti
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties").Value = "Excel 8.0"
        .Properties("Data Source").Value = Kaynak
        .CursorLocation = adUseClient
        .Mode = adModeReadWrite
        .Open
    End With
    If Err = 0 Then
    Set Kayit1 = CreateObject("ADODB.Recordset")
    With Kayit1
        .ActiveConnection = Baglanti
        .CursorLocation = adUseServer
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Source = SQLStr
        .Open
    End With
 '***********************************************************************
    If Kayit1.RecordCount > 0 Then
            s1.Range("a3:d1000").ClearContents
            sat = 2
            Kayit1.MoveFirst
            For i = 1 To Kayit1.RecordCount
                    s1.Cells(sat + i, "a").Value = Kayit1.AbsolutePosition
                    s1.Cells(sat + i, "b").Value = Kayit1(0) * 1
                    s1.Cells(sat + i, "c").Value = Kayit1(1)
                    s1.Cells(sat + i, "d").Value = Kayit1(2)
                    Kayit1.MoveNext
            Next i
     MsgBox "Kayıtlar Başarıyla Alındı.", vbInformation, "Bilgi"
    Else
    MsgBox "Kayıt Bulunamadı.", vbInformation, "Bilgi"
    End If
Else
Son:
    MsgBox "Bağlantı Hatası.Kontrol Ediniz", vbInformation, "Bilgi"
End If
 
If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close
Set Kayit1 = Nothing
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close
Set Baglanti = Nothing
End Sub

 

[hsayar]

teşekkür ederim. hocam.
.Cells(2, "A").CopyFromRecordset KsADODB
şeklinde bir kullanım mümkün mü peki bu şekilde yapınca?

 

[hsayar]

Recep hocam tekrar teşekkür ederim. 3. mesajımdaki sorumun cevabını Zeki hocamdan aldım... Şimdiki sorum, sorgumuz 3 ila 1000. satırlar arasında olsun diyelim.
1) Son kaydın bulunduğu satır 250 ancak benzersizleri süz dediğimiz için 250 ila 1000 satırlar arasındaki 750 boş kaydın 1 inide benzersizler arasına dahil edip, ilk satıra yerleştiriyor.
2) yada 3 ila 1000. satırların hepsi dolu 755. satır silinmiş bu durumdada benzersiz kayıt olarak getiriyor.

Demek istediğim sorguda boş alanlar hariç olarak düzenle demek mümkün mü?
1. soru için son satır bulunup 1000 yerine 250. satırda sorgu bitirilebilir, bunun farkındayım. ancak 2. soru için SqlSorgusunda boş benzersizler hariç demenin yöntemi nedir?

Option Explicit
Sub Adodb_BenzersizKayıtÇek()
'Recep İpek'in ve Zeki Gürsoy'un Katkılarıyla, HSayar tarafından düzenlenmiştir.
'On Error Resume Next
Dim CKtp_Bu     As Workbook:            Set CKtp_Bu = ThisWorkbook                                                                                '||
Dim CSfData     As Worksheet:           Set CSfData = CKtp_Bu.Sheets("DATA")
Dim CSfOzet     As Worksheet:           Set CSfOzet = CKtp_Bu.Sheets("Ozet")

Dim adbBagl As ADODB.Connection
Dim adbKset As ADODB.Recordset
Dim sqlSatr$, sqlFrom$, sqlKynk$

sqlKynk = ThisWorkbook.FullName
sqlFrom = "[" & CSfData.Name & "$" & "A3:C18" & "]"
sqlSatr = "SELECT DISTINCT * FROM " & sqlFrom
    
  Set adbBagl = CreateObject("ADODB.Connection")
  With adbBagl
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .Properties("Extended Properties").Value = "Excel 8.0"
    .Properties("Data Source").Value = sqlKynk
    .CursorLocation = adUseClient
    .Mode = adModeReadWrite
    .Open
  End With
  
  If Err = 0 Then
    Set adbKset = CreateObject("ADODB.Recordset")
    With adbKset
      .ActiveConnection = adbBagl
      .CursorLocation = adUseServer
      .CursorType = adOpenKeyset
      .LockType = adLockOptimistic
      .Source = sqlSatr
      .Open
    End With
'***********************************************************************
    If adbKset.RecordCount > 0 Then
      With CSfOzet
        .Cells.Clear
        .Range(.Cells(1, 1), .Cells(1, 3)).Value = Array("Sayac_No", "Adi_Soyadi", "Mevkii")
        .Range("a2").CopyFromRecordset adbKset
      End With
      'MsgBox "Kayıtlar Başarıyla Alındı.", vbInformation, "Bilgi"
    Else
      MsgBox "Kayıt Bulunamadı.", 16, "Bilgi"
    End If
  Else
Son:
    MsgBox "Bağlantı Hatası Kontrol Ediniz", vbInformation, "Bilgi"
End If
 
If CBool(adbKset.State And adStateOpen) = True Then adbKset.Close:  Set adbKset = Nothing
If CBool(adbBagl.State And adStateOpen) = True Then adbBagl.Close:  Set adbBagl = Nothing

Set CKtp_Bu = Nothing:  Set CSfData = Nothing:  Set CSfOzet = Nothing
End Sub

 

[Haluk]

test........

 

[Recep İpek]

Kodlarınızı aşağıdaki şekilde değiştirerek deneyiniz.Umarım 2 soru içinde cevap olur.

Sub Adodb_BenzersizKayıtÇek()
'Recep İpek'in ve Zeki Gürsoy'un Katkılarıyla, HSayar tarafından düzenlenmiştir.
'On Error Resume Next
Dim CKtp_Bu     As Workbook:            Set CKtp_Bu = ThisWorkbook                                                                                '||
Dim CSfData     As Worksheet:           Set CSfData = CKtp_Bu.Sheets("DATA")
Dim CSfOzet     As Worksheet:           Set CSfOzet = CKtp_Bu.Sheets("Ozet")
Dim adbBagl As ADODB.Connection
Dim adbKset As ADODB.Recordset
Dim sqlSatr$, sqlFrom$, sqlKynk$
sqlKynk = ThisWorkbook.FullName
sqlFrom = "[" & CSfData.Name & "$" & "[COLOR=blue]A2:C100[/COLOR]" & "]"
sqlSatr = "SELECT DISTINCT * FROM " & sqlFrom & [COLOR=blue]"WHERE Sayac_No IS NOT NULL"[/COLOR]
    
  Set adbBagl = CreateObject("ADODB.Connection")
  With adbBagl
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .Properties("Extended Properties").Value = "Excel 8.0"
    .Properties("Data Source").Value = sqlKynk
    .CursorLocation = adUseClient
    .Mode = adModeReadWrite
    .Open
  End With
  
  If Err = 0 Then
    Set adbKset = CreateObject("ADODB.Recordset")
    With adbKset
      .ActiveConnection = adbBagl
      .CursorLocation = adUseServer
      .CursorType = adOpenKeyset
      .LockType = adLockOptimistic
      .Source = sqlSatr
      .Open
    End With
'***********************************************************************
    If adbKset.RecordCount > 0 Then
      With CSfOzet
        .Cells.Clear
        .Range(.Cells(1, 1), .Cells(1, 3)).Value = Array("Sayac_No", "Adi_Soyadi", "Mevkii")
        .Range("a2").CopyFromRecordset adbKset
      End With
      'MsgBox "Kayıtlar Başarıyla Alındı.", vbInformation, "Bilgi"
    Else
      MsgBox "Kayıt Bulunamadı.", 16, "Bilgi"
    End If
  Else
Son:
    MsgBox "Bağlantı Hatası Kontrol Ediniz", vbInformation, "Bilgi"
End If
 
If CBool(adbKset.State And adStateOpen) = True Then adbKset.Close:  Set adbKset = Nothing
If CBool(adbBagl.State And adStateOpen) = True Then adbBagl.Close:  Set adbBagl = Nothing
Set CKtp_Bu = Nothing:  Set CSfData = Nothing:  Set CSfOzet = Nothing
End Sub

 

[Haluk]

yarım saattir cevabı yollamaya debeleniyordum ben de ... :mrgreen:

 

[hsayar]

hocam teşekkür ederim ancak aşağıdaki sqlSatr değeri aşağıdaki şekilde olduğunda gerekli bir veya daha fazla parametre yok hatası alıyorum.

sqlSatr = "SELECT DISTINCT * FROM " & sqlFrom & "WHERE Sayac_No IS NOT NULL"

özür dilerim 2.satırdan (başlıklar satırı) başlatmayı unutmuşum.

Saygıdeğer hocalarım şimdiki sorum ise şu (Fazla oluyorum galiba);
Bu porsodürü Recordseti bir diziye atayacak şekilde fonksiyona dönüşürebilirmiyiz.
Bu prosodür 3 veya dört userformda kullanılarak değerler listbox veya comboya gelecek...
Mevcut halde aşağıdaki değişiklikle (Zeki hocam sayesinde) halledilebiliyor

    If adbKset.RecordCount > 0 Then
      With ListBox1
        .ColumnCount = 3
        .Column = adbKset.GetRows
      End With
    Else
      MsgBox "Kayıt Bulunamadı.", 16, "Bilgi"
    End If

ancak benim demek istediğim

      With ListBox1
        .ColumnCount = 3
        .Column [COLOR=Red]= fncAdobBenzersiz()[/COLOR]
      End With

gibi bir olay. yardımlarınız için teşekkürler.