30 excel dosyasi içinde bir kelime aratma
ID :
22
ISLEM :
30 excel dosyasi içinde bir kelime aratma
MAKRO KODU :
Alpenin çözümüde olur ama kod olarak da;Dosyaları Sayfanıza ekliyerek,Görerek Bulabilirsiniz.Burada excellerin yolu olarak
D:\Belgelerim aldım.Siz yolu değiştirebilrsiniz.Kodları modüle yapıştırın.Daha sonra Butona FileList makrosunu atayın.Kod:
Sub FileList()
Dim FileNamesList As Variant, i As Integer
FileNamesList = CreateFileList("*.xls", True)
Range("A:B").ClearContents
For i = 1 To UBound(FileNamesList)
Cells(i + 1, 1) = FileNamesList(i)
Cells(i + 1, 2) = FileSize(Dir(FileNamesList(i)))
Next
Columns("A:B").AutoFit
End Sub
Function CreateFileList(FileFilter As String, IncludeSubFolder As Boolean) As Variant
Dim FileList() As String, FileCount As Long
CreateFileList = ""
Erase FileList
With Application.FileSearch
.NewSearch
.LookIn = "D:\Belgelerim\"
.Filename = FileFilter
.SearchSubFolders = IncludeSubFolder
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim FileList(.FoundFiles.Count)
For FileCount = 1 To .FoundFiles.Count
FileList(FileCount) = .FoundFiles(FileCount)
Next
End With
CreateFileList = FileList
Erase FileList
End Function
Function FileSize(filespec)
Dim fs, f, f1, fc
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("D:\Belgelerim\")
Set fc = f.Files
For Each f1 In fc
If f1.Name = filespec Then FileSize = f1.Size / 1024 & " Kb"
Next
End Function
Dosyalar Geldikten Sonra şu makro ile Dosyaların adlarını ayırarak İstediğin dosyayı fonksiyonlarla Bulabilirsin..Tabi bu yöntem tam istediğiniz değil ama yinede örnek olarak bulunsun.Kod:
Sub ayır()
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
ActiveWindow.ScrollColumn = 2
End Sub