Kod:
Private Sub CommandButton1_Click()
Dim Con As Object, Rs As Object, Fso As Object, Klasor As Object, Dosyalar As Object
Dim Sorgu As String, Yol As String, Dosya As String
Dim Sutun As Byte
Set Con = CreateObject("AdoDb.Connection")
Set Rs = CreateObject("AdoDb.RecordSet")
Set Fso = CreateObject("Scripting.FileSystemObject")
Yol = ThisWorkbook.Path
Set Klasor = Fso.GetFolder(Yol)
Range("B2:D5").ClearContents
Sutun = 2
For Each Dosyalar In Klasor.Files
If Dosyalar.Name < "ana.xls" Then
Dosya = Replace(Dosyalar.Name, ".xls", "")
Con.Open "Provider=Microsoft.Jet.OleDb.4.0;Data Source=" & _
ThisWorkbook.Path & "\" & Dosya & ".xls" & ";Extended Properties=""Excel 8.0;HDR=NO"""
Sorgu = "Select F4 FROM [Sayfa1$A2:D5]"
Rs.Open Sorgu, Con, 1, 3
Cells(2, Sutun).CopyFromRecordset Rs
Rs.Close
Con.Close
Sutun = Sutun + 1
End If
Next Dosyalar
Set Con = Nothing
Set Rs = Nothing
Set Fso = Nothing
Set Klasor = Nothing
Set Dosyalar = Nothing
Yol = vbNullString
Dosya = vbNullString
End Sub
istediğim şudur.
Ana isimli dosyanın sütun 1.deki yazılana bakacak, tablo1de onu bulduğunda karşısındaki degeri ana tablosuna getirecek. ve bu işlemi Tablo1 ve Tablo2 dede yapacak. Ayrıca sadece ilk dört satırı değil tüm sutun icin bunu yapacak.
Teşekkür ederim.
Ekli dosyalar
-
22 KB Görüntüleme: 40
Son düzenleme: