Kapalı dosyadan açık dosyaya benzersiz veri alma yardımı

[Believing]

Sayı Uzman Arkadaşlar,

Aynı klasör içerisinde bulunan "DATA_(Extra Posting)" isimli kapalı çalışma kitabından açık olan çalışma kitabına günlük veri alarak bir veritabanı oluşturmak istiyorum. Açık olan dosyada bulunan CommandButon1 yardımı ile kapalı çalışma kitabını 3. satırından başlayan "A" sütunları aralığındaki veriler transfer edilecektir. Günlük olarak yapılacak bu işlemde mükerrer kayıt oluşturumamasına dikkat edilerek transfer işlemini maalesaf sağlayamadım. Siz uzman arkadaşların çok değerli yardımlarını rica ediyorum.

Saygılarımla.

Önrek Çalışma Link;
http://dosya.co/dsc6fzy23imz/Extra_Posting_Reports.rar.html

 

[Orion1]

Hangi sütunda mükerrer kontrolu yapılacak?

 

[Believing]

Sayın Orion1,

Aslında kayıt tarihi olan "D" sütununda yapılacaktır. Eğer mümkünse "B:K" aralığında kontol yaptırırsanız çok güzel olur. Mükün değilse de sade "D" sütunu mevcut sorunlarımızı çözecektir.

Saygılarımla.

 

[Orion1]

Sayın Orion1,

Aslında kayıt tarihi olan "D" sütununda yapılacaktır. Eğer mümkünse "B:K" aralığında kontol yaptırırsanız çok güzel olur. Mükün değilse de sade "D" sütunu mevcut sorunlarımızı çözecektir.

Saygılarımla.

Data dosyanızda son 2 satır alanın biçiminde değil.O satırları almadım.
Dosyanız ektedir.

Sub adoileverialma()
Dim conn As Object, rs As Object, k As Range, sat As Long, i As Long
Range("A4:Q" & Rows.Count).ClearContents
sat = 4
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\DATA_(Extra Posting).xls;extended properties=""excel 12.0;hdr=yes"";")
rs.Open "select * from [Sheet1$A2:P65536];", conn, 1, 1
rs.movefirst
Do While Not rs.EOF
    say = say + 1
    If say >= rs.RecordCount - 2 Then Exit Do
    Set k = Range("E4:E" & Rows.Count).Find(rs(3).Value, , xlValues, xlWhole)
    If k Is Nothing Then
        Cells(sat, "A").Value = sat - 3
        For i = 2 To 17
            Cells(sat, i).Value = rs(i - 2).Value
            
        Next i
        sat = sat + 1
    End If
    rs.movenext
Loop
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
Set k = Nothing
MsgBox "veriler çekildi." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[Believing]

Sayın Orion1,

Konuya gösterdiğiniz ilgi ve desteğiniz için teşekkür eder, şükranlarımı iletirim.
Yeni birşey fark ettim, eski verileri silmesi gereklidir. Eski verilerin altına yenilerini eklemesi ve eksi verileri sorgulayarak mükerrer kayıtları engellemelidir.
ALLAH sizde razı olsun ve her şeyi gönlünüze hayırlısı ile nasip etsin.

Saygılarımla.
Ömer Ali ÜZÜMCÜ

 

[Orion1]

Sayın Orion1,

Konuya gösterdiğiniz ilgi ve desteğiniz için teşekkür eder, şükranlarımı iletirim.
Yeni birşey fark ettim, eski verileri silmesi gereklidir. Eski verilerin altına yenilerini eklemesi ve eksi verileri sorgulayarak mükerrer kayıtları engellemelidir.
ALLAH sizde razı olsun ve her şeyi gönlünüze hayırlısı ile nasip etsin.

Saygılarımla.
Ömer Ali ÜZÜMCÜ

Eski verileri zaten siliyor.
Siz D sütunundaki tarihi baz alacak demiştiniz.
Mükerrer bir tarih yok.Siz bana 2 tane mükerer tarih olan satır noso verebilirmisiniz?

 

[Believing]

Sayın Orion1,

Evet haklısınız, hata bende konuyu doğru ifade edememişim.
Mükerrer kayıtları almıyor, bu tam istediğim gibi olmuş. DATA_(Extra Posting) isimli çalışma kitabına yeni güne ait farlı veriler işlenecek, dolayısıla bugün transfer ettiğimiz bugüne ait bilgiler AÇIK isimli çalışma kitabında saklaması, yeni güne ait verileride ilk boş satırdan itibaren almasını sağlamaya çalışıyorum.

Saygılarımla,

 

[Orion1]

Sayın Orion1,

Evet haklısınız, hata bende konuyu doğru ifade edememişim.
Mükerrer kayıtları almıyor, bu tam istediğim gibi olmuş. DATA_(Extra Posting) isimli çalışma kitabına yeni güne ait farlı veriler işlenecek, dolayısıla bugün transfer ettiğimiz bugüne ait bilgiler AÇIK isimli çalışma kitabında saklaması, yeni güne ait verileride ilk boş satırdan itibaren almasını sağlamaya çalışıyorum.

Saygılarımla,

Mükerrer olmayan bu günkü tarihi sayfaya çekiyor.
Kodlar aşağıdadır.

Sub adoileverialma()
Dim conn As Object, rs As Object, k As Range, sat As Long, i As Long
Range("A4:Q" & Rows.Count).ClearContents
sat = 4
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\DATA_(Extra Posting).xls;extended properties=""excel 12.0;hdr=yes"";")
rs.Open "select * from [Sheet1$A2:P65536];", conn, 1, 1
rs.movefirst
Do While Not rs.EOF
    say = say + 1
    If say >= rs.RecordCount - 1 Then Exit Do
    Set k = Range("E4:E" & Rows.Count).Find(rs(3).Value, , xlValues, xlWhole)
    If rs(3).Value = Date Then
        If k Is Nothing Then
                Cells(sat, "A").Value = sat - 3
                For i = 2 To 17
                    Cells(sat, i).Value = rs(i - 2).Value
                Next i
                sat = sat + 1
        End If
    End If
    rs.movenext
Loop
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
Set k = Nothing
MsgBox "veriler çekildi." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[Believing]

Sayın Orion1,

Açık olan çalışma kitabındaki veriler muhafaza edilecek, yeni veriler daha önce alınan verilerin altına ile edeilecek, bu işlem yapılırken de AÇIK isimli kitaptabındaki eski verilerde mükerrer kayıt kontrolünün yapılmasını sağlamak istiyorum.

Saygılarımla,

 

[Orion1]

Sayın Orion1,

Açık olan çalışma kitabındaki veriler muhafaza edilecek, yeni veriler daha önce alınan verilerin altına ile edeilecek, bu işlem yapılırken de AÇIK isimli kitaptabındaki eski verilerde mükerrer kayıt kontrolünün yapılmasını sağlamak istiyorum.

Saygılarımla,

Buyurun.

DOSYAYI İNDİR

Sub adoileverialma()
Dim conn As Object, rs As Object, k As Range, sat As Long, i As Long
Range("A4:Q" & Rows.Count).ClearContents
[B][COLOR="Red"]sat = Cells(Rows.Count, "E").End(xlUp).Row + 1[/COLOR][/B]
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\DATA_(Extra Posting).xls;extended properties=""excel 12.0;hdr=yes"";")
rs.Open "select * from [Sheet1$A2:P65536];", conn, 1, 1
rs.movefirst
Do While Not rs.EOF
    say = say + 1
    If say >= rs.RecordCount - 1 Then Exit Do
    Set k = Range("E4:E" & Rows.Count).Find(rs(3).Value, , xlValues, xlWhole)
    If rs(3).Value = Date Then
        If k Is Nothing Then
                Cells(sat, "A").Value = sat - 3
                For i = 2 To 17
                    Cells(sat, i).Value = rs(i - 2).Value
                Next i
                sat = sat + 1
        End If
    End If
    rs.movenext
Loop
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
Set k = Nothing
MsgBox "veriler çekildi." & vbLf & "evrengizlen@hotmail.com"
End Sub