Merhaba,
yüzlerce aynı formatta ve içerikleri aynı olan xls lerin bulunduğu bir klasor icinden belirli numaralara sahip olan satırların aranarak (J kolonundaki bilgi) arama yapmak icin numaraları yazmıs olduğum xls in ikinci sheetinde J kolonunda aramıs olduğumuz numaranın satırı alt alta komple yazacak bir makroya ihtiyacım bulunuyor.
Örnekle anlatmam gerekirse örnek xls tablosunda A kolonunda bulunan hesap nolarını birden cok xls icinde içeriği örnek in ikinci sheetinde bulunan J kolonunda arayarak örnek cıktı gibi vericek bir makro yazmak istiyorum.
Bir tane bu konuda deneme yaptım fakat beceremedim yazılan makroda aşağıda yer alıyor.
Yardımlarınız icin şimdidencok teşekkür ederim.
Sub Macro1()
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, "J").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 [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ı." & _
"", vbOKOnly + vbInformation, ""
End Sub
yüzlerce aynı formatta ve içerikleri aynı olan xls lerin bulunduğu bir klasor icinden belirli numaralara sahip olan satırların aranarak (J kolonundaki bilgi) arama yapmak icin numaraları yazmıs olduğum xls in ikinci sheetinde J kolonunda aramıs olduğumuz numaranın satırı alt alta komple yazacak bir makroya ihtiyacım bulunuyor.
Örnekle anlatmam gerekirse örnek xls tablosunda A kolonunda bulunan hesap nolarını birden cok xls icinde içeriği örnek in ikinci sheetinde bulunan J kolonunda arayarak örnek cıktı gibi vericek bir makro yazmak istiyorum.
Bir tane bu konuda deneme yaptım fakat beceremedim yazılan makroda aşağıda yer alıyor.
Yardımlarınız icin şimdidencok teşekkür ederim.
Sub Macro1()
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, "J").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 [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ı." & _
"", vbOKOnly + vbInformation, ""
End Sub