Bir veriyi diğer excel tablolarından alabilmek

[kayra75]

Merhaba,
Ekteki örneklerde deneme ve tarihler olan xls dosyaları bulunmaktadır. Burada Deneme xls de bulunan barkod numaralarını alarak belli bir folder altında bulunan xls filelarda arayarak bulmak ve bulduğu bu barkod numaralarıyla ilgili satırları deneme xls de sheet2 ye sıralamak.
Bu konuda yardımalrınızı rica ediyorum arkadaslar.

 

[Orion1]

Dosyanız ektedir.
Deneme.xls dosyasıda ayni klasörün içinde olmalıdır.
İlk başladığında en alttaki satırın altından başlar ve devam eder alt alta.

Sub dosyalari_aktar_59()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim sh As Worksheet, sat As Long, sat1 As Long, i As Long
Dim fso As Object, fs As Object, dosya As String, k As Byte
Set sh = Sheets("Sheet2")
Sheets("Sheet1").Select
Application.ScreenUpdating = False
sat1 = Cells(65536, "A").End(xlUp).Row
sat = sh.Cells(65536, "L").End(xlUp).Row + 1
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set fso = CreateObject("Scripting.FileSystemObject")
For Each fs In fso.getfolder(ThisWorkbook.Path).Files
    If Right(fs.Name, 4) = ".xls" And fs.Name <> ThisWorkbook.Name Then
         dosya = fs.Name
        conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\" & dosya & ";extended properties=""excel 8.0;hdr=no"""
            rs.Open "Select * from [Sheet1$A1:O65536];", conn, adOpenKeyset, adLockReadOnly
            rs.MoveFirst
            Do While Not rs.EOF
              If IsNull(rs(11).Value) Then GoTo atla
                If WorksheetFunction.CountIf(Range("A2:A" & sat1), rs(11).Value) > 0 Then
                    For k = 1 To rs.Fields.Count
                        sh.Cells(sat, k).Value = rs(k - 1).Value
                    Next k
                    sat = sat + 1
                End If
atla:
                rs.MoveNext
            Loop
           conn.Close
        End If
Next fs
Set rs = Nothing
Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Kapalı dosyalardan veriler aktarıldı." & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[kayra75]

Elinize sağlık..

 

[kayra75]

Merhaba Evren
makroyu calıstırdığım zaman aşağıdaki satırda uyarı alıyorum neden olabilir sence ?

rs.Open "Select * from [Sheet1$A1:O65536];", conn, adOpenKeyset, adLockReadOnly

 

[Orion1]

Merhaba Evren
makroyu calıstırdığım zaman aşağıdaki satırda uyarı alıyorum neden olabilir sence ?

rs.Open "Select * from [Sheet1$A1:O65536];", conn, adOpenKeyset, adLockReadOnly

Klasörde bulunan dosyaların bir tanesinin içinde sheet1 isimli sayfa yok büyük ihtimalle.

 

[kayra75]

Haklısın E V R E N

eline sağlık üstat

 

[Orion1]

Haklısın E V R E N

eline sağlık üstat

Rica ederim.
iyi çalışmalar.