Veritabanında tck&vergi no eşleşenleri ilgili sütuna yazmak

[hsayar]

http://www.excel.web.tr/showthread.php?t=43823
buradaki soruya cevaben açılmıştır server probleminden dolayı link açılmıyor.

veritabanı oluştururken;
tcno var, vkno yoksa> vkno alanına 0 giriniz
tcno yok, vkno varsa> tcno alanına 0 giriniz

sorgu yapılacak sayfadada aynı şekilde yapınız.

sorgu için gerek n sütunun altındaki command butonu gerekse
Makrolar iletişim kutusundaki MukAl makrosunu kullanabilirsiniz.

Sub MukAl()
'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||
'|||||||||| Hsayar 25/01/2008
'|||||||||| Aktif sayfadaki D (TCKimlik), E ( Vergi No) sütunlarındaki numaraları veritabanında arar
'|||||||||| Yazılanlar doğru ise aktif sayfaya alanları kopyalar
'|||||||||| Sorgulanacak firmanın bir alanı boşsa o alana 0 değeri girilmelidir.
'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||'||||||||||
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO As Object
Dim SQLStr, Kaynak, verginosu As String
Dim ckBU As Workbook
Dim csSR As Worksheet
Set ckBU = ThisWorkbook: Set csSR = ckBU.Sheets(ActiveSheet.Name)
'sonsat = csSR.Cells(65536, "E").End(3).Row
Dim stn%, snstr%
Dim arrsnstr()
    
    For stn = 4 To 5
       ReDim Preserve arrsnstr(y)
        arrsnstr(y) = Cells(65536, stn).End(3).Row
        y = y + 1
    Next stn
sonsat = WorksheetFunction.Max(arrsnstr)
Erase arrsnstr
'***********************************************************************
Kaynak = Application.ThisWorkbook.Path & "\" & "vt_Sirk.xls"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(Kaynak) = False Then
    MsgBox Kaynak & " " & " Dosyası Bulunamadı.", vbInformation, "Bilgi"
    Exit Sub
End If
For i = 2 To sonsat
basliklar = "UNVAN, ADRES, TCKN, VKNO"
sayfaadi = "[DATA$]"
sorgu = "VKNO = " & Cells(i, "E").Value & _
        "AND TCKN=" & Cells(i, "D").Value

      SQLStr = "SELECT " & basliklar & " FROM " & sayfaadi & " WHERE " & sorgu
On Error Resume Next
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 = adUseServer
        .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 = 1 Then
          Cells(i, "B").Value = Kayit1("UNVAN")
          Cells(i, "C").Value = Kayit1("ADRES")
    Else
          Cells(i, "B").Value = "BU KİMLİK/VERGİ NOSUNA KAYITLI ŞİRKET YOKTUR"
    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
Set FSO = Nothing
Next i
MsgBox "EŞLEŞTİRME TAMAMLANDI", , "excel.web.tr"
End Sub

 

[purpledarkness]

teşekkür ederim

çok güzel bir çalışma olmuş teşekkür ederim.
ben eskiden veri tabanı dosyamı ayrı bir çalışma kitabında değil, ayların olduğu çalışma kitabı içindeki bir çalışma sayfasında takip ediyordum artık senin yaptığın gibi iki ayrı dosyada takip etmem gerekecek.

 

[hsayar]

icabındabunu şubelere gönderek doğru gelmesinide sağlayabilrisin...
her ay güncellersin
ama ozaman selection_change yazarız.

 

[purpledarkness]

şubelere göndermeyi düşünmüyorum, kendim kontrolü yapmayı düşünüyorum,
şimdi bu vt-sirk adlı dosyayı yani veri tabanı dosyasını diğer aktif çalışma kitabımın içine alamazmıyım, yani tek çalışma kitabında halletmek istiyorum.

 

[hsayar]

onu ben bilmem hocam
aynı klasör altında olması yeterlidir bence