bir dosyadan baska dosyaya veri girişi

[Eser Gökay]

arkadaslar iyi aksamlar. ekte iki adet dosya mevcut.

Soru isimli dosyada ilgili hucreye vergi numarasını girdigim zaman eger veritabani isimli dosyada o vergi numarası mevcutsa musteri bilgilerini formulle alıyor. Benim problemim mevcut olmayanları userform'la veritabani dosyasini acmadan tanımlayabilmek.

 

[Eser Gökay]

arkadaslar yardımcı olabilecek kimse var mı?

 

[Recep İpek]

Ekli dosyanızı inceleyiniz.

 

[Eser Gökay]

Ripek hocama emeklerinden ve bana katlanma nezaketini gösterdiğinden dolayı çok tesekkur eder başarılarının devamını dilerim.

 

[hsayar]

Arkadaşlar benimde bir veritabanaım var ve düşey ara ile aldığım için aynı kitapta bulunmak zorunda. yalnız veritabanım 23288 satırdan oluştuğu için makinede kasılma ve dosya boyutunda büyüme oluyor sn. muhasebecieserin kullandığı şekilde kullanmak istiyorum.
Ancak dosya bir kesit olduğu için ben bir şey anlmadım sadece veritabanında dosyaların alındığı ve olmayanın eklendiğine ilişkne porsodürleri içeren bir örnek eklerseniz sevinirim.

 

[Eser Gökay]

sayın hsayar calismamiz henuz tamamlanmamistir. kodlar bazı yerlerde sıkıntı yaratmakta. sagolsun ripek hocam bu konuda yardımcı olmaya calisiyor. kodlardan dolayı mı sıkıntı var benim bir seyleri kendi dosyama yanlıs uyarlamam mı henuz bilmiyorum. bittiginde sizinle de paylasiriz.

 

[hsayar]

ÇiftçiBilgiSistemi.xls A4 ten itibaren girilen tckimlik nolarını Tckimlik.xls kimlik sayfası A sütununda sorgulayacak ve bulduğu satırdaki istenilen verileri
1) (ADI SOYADI BABAADI ANA ADI DOĞUM YERİ DOĞUM TARİH&#304 bu sayfadaki ilgili sütunlara yazacak.
2) Eğer veritabanında tc kimliknosu yoksa(ADI SOYADI BABAADI ANA ADI DOĞUM YERİ DOĞUM TARİH&#304 verilerini ekleyecek(Buradaki veriler zorunlu, Tckimlik.xlsde verilmiş diğer sütun başlıkları isteğe bağl&#305

 

[hsayar]

sayın hsayar calismamiz henuz tamamlanmamistir. kodlar bazı yerlerde sıkıntı yaratmakta. sagolsun ripek hocam bu konuda yardımcı olmaya calisiyor. kodlardan dolayı mı sıkıntı var benim bir seyleri kendi dosyama yanlıs uyarlamam mı henuz bilmiyorum. bittiginde sizinle de paylasiriz.

aslında bu güzel bir örnek düşey arada çok fazla olunca kasılma olmakta bunu ortafdan kaldırıyor. yalnız ben modül sayfanız fazla olduğu işçin bir şey anlamadım. bittiğinde epey faydalı bir şey ortaya çıkacağa benziyor çalışmalarınızda başarılar dilerim.

 

[hsayar]

Private Sub Worksheet_Change(ByVal Target As Range)
    'On Error Resume Next
    'g sütunu: Vergi No
    'ı:j sütunu: belege trh/no
    If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
    If IsEmpty(Target) Or InStr(1, Target.Address, ":") <> 0 Then
        Cells(Target.Row, "B").ClearContents
        Cells(Target.Row, "C").ClearContents
        Cells(Target.Row, "D").ClearContents
        Cells(Target.Row, "E").ClearContents
        Cells(Target.Row, "F").ClearContents
        Cells(Target.Row, "G").ClearContents
        Exit Sub
    End If
    
    If Cells(Target.Row, "A") <> "" Then
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
    If SAY > 1 Then
    Set BUL = Columns(Target.Column).Find(Target)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
    If Cells(Target.Row, "A") = Cells(BUL.Row, "A") Then
    SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
    End If
    Set BUL = Columns(Target.Column).FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    GoTo UYARI
    End If: End If: End If
    GoTo Baglan
UYARI:     ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")
    If ONAY = vbNo Then
        Cells(Target.Row, "A").ClearContents
        Cells(Target.Row, "B").ClearContents
        Cells(Target.Row, "C").ClearContents
        Cells(Target.Row, "D").ClearContents
        Cells(Target.Row, "E").ClearContents
        Cells(Target.Row, "F").ClearContents
        Cells(Target.Row, "G").ClearContents
        Target.Select
    Exit Sub: End If
    
    '*****************************************************************
'Ripek - 26/12/2007
Baglan:
MsgBox "BEKLEMEDE"
If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO As Object
Dim SQLStr, Kaynak, tcno As String
'***********************************************************************
CurrentRow = Target.Row
CurrentValue = Target.Value

Kaynak = Application.ThisWorkbook.Path & "\" & "Tckimlik.xls"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(Kaynak) = False Then
MsgBox Kaynak & " " & " Dosyas&#305; Bulunamad&#305;.", vbInformation, "Bilgi"
Exit Sub
End If

tcno = Target.Value
'SQLStr = "SELECT M&#220;KELLEFADISOYADI,VDA&#304;RES&#304;,VERG&#304;NO,ADRES&#304; FROM [data$] WHERE VERG&#304;NO=" & verginosu
SQLStr = "SELECT TCKIMLIKNO,ADI,SOYADI,ILK_SOYADI,ANA_ADI,BABA_ADI,C,DGM_YERI,DGM_TRH,NFS_IL,NFS_ILCE,ADR_IL,ADR_ILCE,ADR_MUHTAR,ADR_CD_SKK,ADR_KNO,ADR_DNO,SCM_NO,AD_SYD FROM [data$] WHERE TCKIMLIKNO=" & tcno
'(veritaban&#305;.xls)> M&#220;KELLEFADISOYADI   VDA&#304;RES&#304;    VERG&#304;NO ADRES&#304;
'(tckimlik.xls)> TCKIMLIKNO  ADI SOYADI  ILK_SOYADI  ANA_ADI BABA_ADI    C   DGM_YERI    DGM_TRH NFS_IL  NFS_ILCE    ADR_IL  ADR_ILCE    ADR_MUHTAR  ADR_CD_SKK  ADR_KNO ADR_DNO SCM_NO  AD_SYD
'                   A        B   C       D           E       F           G   H           I       J       K           L       M           N           O            P         Q       R       S
'                   1        2   3       4           5       6           7   8           9       10      11          12      13          14          15           16        17      18      19

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
    [color=rED]    .Open [/COLOR]
    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(CurrentRow, "B").Value = Kayit1("ADI")
          Cells(CurrentRow, "C").Value = Kayit1("SOYADI")
          Cells(CurrentRow, "D").Value = Kayit1("BABA_ADI")
          Cells(CurrentRow, "E").Value = Kayit1("ANA_ADI")
          Cells(CurrentRow, "F").Value = Kayit1("DGM_YERI")
          Cells(CurrentRow, "G").Value = Kayit1("DGM_TRH")
    Else
        MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"
        UserForm1.Show
    End If
Else
Son:
    MsgBox "Ba&#287;lant&#305; Hatas&#305;.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
Target.Offset(1, 0).Select
End Sub

şeklinde denetim ama data$ geçerli bir ad değil hatası veriyor [-2147467259(80004005)]
debug deyince kırmız fontlu satırda hata veriyor.

 

[Eser Gökay]

arkadaslar calisma son halini almıstır. Ripek Hocamın cok degerleri yardımlarına tesekkur ediyorum. konuyla ilgili macoda yol belirtildigi için eki d:\belgelerim\ altında acarsanız calisacak. degilse kendinize gore macroda yolları degistirmeniz gerekecek

ornegimizi denemek icin
d:\belgelerim\ornek\program_data\dosyalar\dosya.xls açıyoruz. Gider Fiş girişlerine tıklayıp örnek bir vergi numarasını giriyorsunuz. ondan sonrası size kalmış.

tek bir problem kaldı. o da vergi numarasının girildigi alanı delete ile sildigimizde macro hata veriyor. Ripek hocam halleder herhalde ama benim yardım isteyecek yuzum kalmadı. sene sonu yoğunluğu şimdi herkes de bir hengamedir gidiyor zaten.

 

[hsayar]

sn muhasebieser olmayan vergi/tcnoyu ta 1239 dan başlatıyor ilk boş satıra kaydı nasıl sağlayacağız (örnek için 4.satır)

Arkadaşlar ben kendi sorunumu böyle mükemmel bir örnek önümde olmasına rağmen beceremedim bir el atıverseniz gerçekten memnun kalacağım.
saygılarımla

 

[Eser Gökay]

haklısınız da benim veritabani dosyamda 1239 a kadar olan kısım doluydu. foruma gercek bilgi eklememek veritabanının o kısmını silerek koydum. bunu atlamısım ozur dilerim.

 

[Eser Gökay]

sayın hsayar veritabanı dosyanının 4-1239 arası satırları seçip silmişim 4-65536 arasını bütün satırı seçip silerseniz. bir sonraki eklemeyi 4. satıra yapıyor. kod da yanlış yok. macro onları dolu sayıyor. bilginize...

 

[hsayar]

Sayın Muhasebecieser verdiğiniz bilgi için teşekkür ederim.
Delete ile silince hata vermememsi için

Private Sub Worksheet_Change(ByVal Target As Range)
    'On Error Resume Next
[color="blue"]
[B]If Intersect(Target, [G4:G65536]) Is Nothing Then Exit Sub
If Target.Value = "" Then
    Range("E" & Target.Row & ":f" & Target.Row).Select
    Selection.ClearContents
    Range("H" & Target.Row & ":O" & Target.Row).Select
    Selection.ClearContents
    Cells(Target.Row, "G").Select
Exit Sub
Else
Baglan:
End If
[/B][/color]
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO As Object
Dim SQLStr, Kaynak1, Kaynak2, Kaynak3, verginosu As String
'***********************************************************************
CurrentRow = Target.Row
CurrentValue = Target.Value

Kaynak1 = "D:\Belgelerim\Ornek\Program_Data\veritabani.xls"
Kaynak2 = "D:\Belgelerim\Ornek\Program_Data\veritabani.xls"

Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(Kaynak1) = True Then
Kaynak3 = Kaynak1
ElseIf FSO.FileExists(Kaynak2) = True Then
Kaynak3 = Kaynak2
Else
MsgBox "Veritabani.xls Dosyası Bulunamadı.", vbInformation, "Bilgi"
Exit Sub
End If
verginosu = CurrentValue
SQLStr = "SELECT MÜKELLEFADISOYADI,VDAİRESİ,VERGİNO,ADRESİ FROM [data$] WHERE VERGİNO=" & verginosu
Set Baglanti = CreateObject("ADODB.Connection")
    With Baglanti
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties").Value = "Excel 8.0"
        .Properties("Data Source").Value = Kaynak3
        .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(CurrentRow, "e").Value = Kayit1("MÜKELLEFADISOYADI")
          Cells(CurrentRow, "f").Value = Kayit1("VDAİRESİ")
          Cells(CurrentRow, "h").Value = Kayit1("ADRESİ")
    Else
        MsgBox "Aradığınız Kayıt Bulunamadı.", vbInformation, "Bilgi"
        UserForm1.Show
    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
Target.Offset(1, 0).Select
End Sub

değiştiriniz.

 

[Eser Gökay]

ben de cok tesekkur ederim. herkese iyi calismalar...

 

[Eser Gökay]

Arkadaslar iyi geceler...

sayın Recep İpek'in cok buyuk emekleri ile olusturulmus olan veritabanından bilgi alma calismasiyla ilgili olarak bir ARAMA-BULMA-DEĞİŞTİRME gibi fonksiyona ihtiyac duydum. daha ayrıntılı bilgi ekte. ilgilerinize tesekkur ederim simdiden

 

[Recep İpek]

Ekli dosyanızı inceleyiniz.
Kodlarda değişliklik yaptım.

Bunlar;

--Kaynak yolları ve değişkenler Modüle10 içinde tanımlandı.
--Veritabanı dosyasını Excel yerine Access olarak değiştirildi.Bu şekilde birden fazla kişi açınca hata olmaması gerekiyor.
--Bu Access dosyasına ABC şeklinde şifre tanımladım.Böylelikle veri güvenliğide sağlanmış oldu.
--Kayıt eklerken ve düzeltirken şifre sorulması sağlandı.Şifre ESER
--Adı Soyadı ve Vergi Numarasına göre arama yapılabiliniyor.
--Listbox'da çift tıklama ile veriler Textbox'a, buradanda Seçili Kayıdı Sayfata Aktar ile de seçtiğiniz hücreye aktarıyor.
--

Umarım işinize yarar.

 

[Eser Gökay]

Recep Bey'e emeklerinden ve zaman ayırma nezaketini gostermesinden dolayı ne kadar tesekkur etsem azdır. Tek kelimeyle ŞAHANE olmuş.