Merhaba,
Aşağıda yazılmış olan makroda numeric L kolonunda bulunan numeric karakterileri aramakta iken Alfebetik olanları arıyamıyorum. Bu konuda yardımınızı rica ediyorum.
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 = True
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 [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
Aşağıda yazılmış olan makroda numeric L kolonunda bulunan numeric karakterileri aramakta iken Alfebetik olanları arıyamıyorum. Bu konuda yardımınızı rica ediyorum.
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 = True
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 [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