Bilgileri kapalı dosyadan tamamlama

[mnz]

Merhaba,
Açık olan çalışma kitabıma aşağıdaki kodları yazdım. No ya göre kapalı dosyadan mailleri çekerek 25 ci sütuna yazılmasını istedim. Ne yaptıysam olmadı. Açık ve kapalı dosyadaki No ların biçimlerini kontrol ettim yani metin-sayı biçimini. Hepsi GENEL olarak ayarlanmış.
Yardımınızı bekliyorum.

On Error Resume Next
Set DB = New ADODB.Connection
Dim sc As Long
Mth = "C:\Belgelerim\test.XLS"
Set ni = Sheets("db")
tm = ni.[B65536].End(3).Row
DB.Open "Driver={Microsoft Excel Driver (*.xls)}; DBQ=" & Mth
Set RS = New ADODB.Recordset
For r = 4 To tm
sc = ni.Cells(r, 2).Value
SL = "SELECT No, Email FROM [test1$] WHERE No=" & sc
RS.Open SL, DB, 1, 3
ni.Cells(r, 25).Value = RS("Email")
Next
RS.Close
Set RS = Nothing
DB.Close
Set DB = Nothing

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodları deneyiniz.

On Error Resume Next
  Dim sc As Long
     Set ni = Sheets("db")
     tm = ni.[B65536].End(3).Row
     
     Set Db = New ADODB.Connection
     Mth = "C:\Belgelerim\test.XLS"
     Db.Open "Driver={Microsoft Excel Driver (*.xls)}; DBQ=" & Mth
  
     Set RS = New ADODB.Recordset
     For r = 4 To tm
        sc = "'" & ni.Cells(r, 2).Value & "'"
        SL = "SELECT No, Email FROM [test1$] WHERE No=" & sc
        RS.Open SL, Db, 1, 3
        RS.movefirst
        If Not IsEmpty(RS.Count) Then: ni.Cells(r, 25).Value = RS(1)
'        RS.Close
     Next
RS.Close
Set RS = Nothing
Db.Close
Set Db = Nothing

 

[mnz]

Sayın fpc ilginize teşekkürler. Bütün hepsine aynı mail adresini yazıyor. Yani kapalı dosyada bulunan en baştaki maili hepsine ekledi.

 

[Haluk]

Alternatif:

Söz konusu No isimli alan yerine SiraNo kullanın. Yani, kapalı dosyada No olan sütun başlığını SiraNo olarak değiştirin ve aşağıdaki kodları deneyin;

Sub Test()
    Dim DB As Object
    Dim RS As Object
    Dim KapDosya As String
    Dim sc As Long, r As Long
    
    Set ni = Sheets("db")
    tm = ni.[B65536].End(3).Row
    
    KapDosya = "C:\Belgelerim\test.XLS"
    
    On Error Resume Next
        Set daoDBEngine = CreateObject("DAO.DBEngine")
        Set daoDBEngine = CreateObject("DAO.DBEngine.36")
    On Error GoTo 0
    
    Set DB = daoDBEngine.OpenDatabase(KapDosya, False, False, "Excel 8.0")
    
    For r = 4 To tm
        sc = ni.Cells(r, 2)
        Set RS = DB.OpenRecordset("SELECT SiraNo, Email FROM [test1$] WHERE SiraNo=" & sc)
        If RS.RecordCount > 0 Then ni.Cells(r, 25).Value = RS(1)
        RS.Close
    Next
    
    DB.Close
    Set RS = Nothing
    Set DB = Nothing
    Set daoDBEngine = Nothing
End Sub

 

[mnz]

Alternatif:

Söz konusu No isimli alan yerine SiraNo kullanın. Yani, kapalı dosyada No olan sütun başlığını SiraNo olarak değiştirin ve aşağıdaki kodları deneyin;

Sub Test()
    Dim DB As Object
    Dim RS As Object
    Dim KapDosya As String
    Dim sc As Long, r As Long
    
    Set ni = Sheets("db")
    tm = ni.[B65536].End(3).Row
    
    KapDosya = "C:\Belgelerim\test.XLS"
    
    On Error Resume Next
        Set daoDBEngine = CreateObject("DAO.DBEngine")
        Set daoDBEngine = CreateObject("DAO.DBEngine.36")
    On Error GoTo 0
    
    Set DB = daoDBEngine.OpenDatabase(KapDosya, False, False, "Excel 8.0")
    
    For r = 4 To tm
        sc = ni.Cells(r, 2)
        Set RS = DB.OpenRecordset("SELECT SiraNo, Email FROM [test1$] WHERE SiraNo=" & sc)
        If RS.RecordCount > 0 Then ni.Cells(r, 25).Value = RS(1)
        RS.Close
    Next
    
    DB.Close
    Set RS = Nothing
    Set DB = Nothing
    Set daoDBEngine = Nothing
End Sub

Üstad verdiğiniz kodlar gayet güzel çalışıyor da, ben sizin yazdığınız kodları anlamaya çalışınca bildiklerim de gidiyor Yada çok geriden geliyoruz.
Teşekkürler.

 

[Ferhat Pazarçevirdi]

Sn.Haluk'un kullandığı yöntem : DAO (Data Access Object)
Sizin kodlarınızdaki ise ADO (Activex Data Object)

Aşağıdaki kodlar; yine ADO ile oluşturulmuştur. Deneyiniz.

Dim sc As Long
     Set ni = Sheets("db")
     tm = ni.[B65536].End(3).Row
     Set Db = New ADODB.Connection
     Mth = "C:\Belgelerim\test.XLS"
     Db.Open "Driver={Microsoft Excel Driver (*.xls)}; DBQ=" & Mth
     On Error Resume Next
     Set RS = New ADODB.Recordset
     For r = 4 To tm
        sc = ni.Cells(r, 2)
        SL = "SELECT [No], Email FROM [test1$] WHERE [No]=" & sc
        RS.Open SL, Db, 1, 3
        ni.Cells(r, 25) = RS(1)
        RS.Close
     Next
Db.Close
Set Db = Nothing
Set RS = Nothing
Set ni = Nothing

 

[mnz]

Sn.Haluk'un kullandığı yöntem : DAO (Data Access Object)
Sizin kodlarınızdaki ise ADO (Activex Data Object)

Aşağıdaki kodlar; yine ADO ile oluşturulmuştur. Deneyiniz.

Dim sc As Long
     Set ni = Sheets("db")
     tm = ni.[B65536].End(3).Row
     Set Db = New ADODB.Connection
     Mth = "C:\Belgelerim\test.XLS"
     Db.Open "Driver={Microsoft Excel Driver (*.xls)}; DBQ=" & Mth
     On Error Resume Next
     Set RS = New ADODB.Recordset
     For r = 4 To tm
        sc = ni.Cells(r, 2)
        SL = "SELECT [No], Email FROM [test1$] WHERE [No]=" & sc
        RS.Open SL, Db, 1, 3
        ni.Cells(r, 25) = RS(1)
        RS.Close
     Next
Db.Close
Set Db = Nothing
Set RS = Nothing
Set ni = Nothing

Önce teşekkür ediyim sonra denerim.