Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Найти текст и при его наличии вывести название файла - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Найти текст и при его наличии вывести название файла (Макросы/Sub)
Найти текст и при его наличии вывести название файла
ant6729 Дата: Среда, 09.01.2019, 22:43 | Сообщение № 1
Группа: Проверенные
Ранг: Ветеран
Сообщений: 519
Репутация: 2 ±
Замечаний: 40% ±

Excel 2010
Всем привет, ищу определенный текст в большом количестве текстовых файлов, и название файла, содержащего этот текст

Ищу примерно так.

[vba]
Код
Option Explicit
Dim fsoFile As file, fsoFolder As Folder
Dim key As Variant
Dim dict As Scripting.Dictionary

Sub You()

    'Dim fsoFile As file, fsoFolder As Folder
    Dim ReportFile
    
    Dim fso As New FileSystemObject
    Dim Spath, StrFile, lr, fj, Sal
    Spath = Application.ThisWorkbook.Path & "\"
    Set fsoFolder = fso.GetFolder(Spath)
    
    Set dict = New Scripting.Dictionary
    
    For Each fsoFile In fsoFolder.Files

        If fsoFile Like "*.txt" Then Call sort

    Next fsoFile
    
    SortDictionary dict

    With dict
    
        For Each key In .Keys
        'For key = 1 To 5
            Debug.Print key, .Item(key)
        Next
        
    
    
    
    Range("A1").Resize(, 2) = Array("Values", ".txtName")
'    Range("A2").Resize(5) = Application.Transpose(.Keys)
'    Range("B2").Resize(5) = Application.Transpose(.Items)
    Range("A2").Resize(.Count) = Application.Transpose(.Keys)
    Range("B2").Resize(.Count) = Application.Transpose(.Items)
    '[a1].sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
    'fj = Application.Max(.Keys)
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    'Sal = Application.WorksheetFunction.VLookup(fj, Range("A2:B" & lr), 2, False)
    'MsgBox "Ìàêñèìàëüíîå çíà÷åíèå ñðåäè ôàéëîâ:" & vbNewLine & Application.Max(.Keys) & " â " & Sal
    
    End With
    

    
    
    
  
End Sub

Sub sort()

        Open fsoFile For Input As #1
        Dim s As String
        Dim m, k
        
        While Not EOF(1)
            Input #1, s
            On Error Resume Next
            
            m = (CatchNum(s))
          
            'm = Int(Left(s, 10))
            'm = Split((Split(s, " ")(0)), ",")(1)
            'm = Int(Left(Split(s, ",")(1), 3))
            
            dict.Add m, fsoFile.Name
        Wend
        
        Close #1
        
End Sub

Sub SortDictionary(dict As Object)

    Dim i As Long
    
    With CreateObject("System.Collections.SortedList")
        For Each key In dict
        On Error Resume Next
            .Add key, dict(key)
        Next
        dict.RemoveAll

        For i = 0 To .Keys.Count - 1
            dict.Add .GetKey(i), .Item(.GetKey(i))
        Next
        
    End With
End Sub
Function CatchNum(s As String) As Long
    Dim objRegExp, SubobjMatches
        Set objRegExp = CreateObject("VBScript.RegExp")
        objRegExp.Global = True
        objRegExp.Pattern = "1037604"
        'objRegExp.Pattern = "[^,]+,([\d]+)"
        Set SubobjMatches = objRegExp.Execute(s)
        CatchNum = SubobjMatches(0).Value
End Function
[/vba]

Но это мертвая процедура
Файлов бывает 300 штук, каждый по 5 кб txt Строк может быть и 20000

Есть ли возможности оптимизации?

Если раньше искал по паттерну, то теперь просто хочу найти по значению.
В принципе, могу просто убрать процедуру с регулярными выражениями. Но насколько это ускорит, не знаю.
Хотелось бы услышать и увидеть варианты оптимизации для этой задачи на Excel.

Неужели Excel не подходит для больших данных...
К сообщению приложен файл: Script_example.xlsb(20.0 Kb)
 
Ответить
СообщениеВсем привет, ищу определенный текст в большом количестве текстовых файлов, и название файла, содержащего этот текст

Ищу примерно так.

[vba]
Код
Option Explicit
Dim fsoFile As file, fsoFolder As Folder
Dim key As Variant
Dim dict As Scripting.Dictionary

Sub You()

    'Dim fsoFile As file, fsoFolder As Folder
    Dim ReportFile
    
    Dim fso As New FileSystemObject
    Dim Spath, StrFile, lr, fj, Sal
    Spath = Application.ThisWorkbook.Path & "\"
    Set fsoFolder = fso.GetFolder(Spath)
    
    Set dict = New Scripting.Dictionary
    
    For Each fsoFile In fsoFolder.Files

        If fsoFile Like "*.txt" Then Call sort

    Next fsoFile
    
    SortDictionary dict

    With dict
    
        For Each key In .Keys
        'For key = 1 To 5
            Debug.Print key, .Item(key)
        Next
        
    
    
    
    Range("A1").Resize(, 2) = Array("Values", ".txtName")
'    Range("A2").Resize(5) = Application.Transpose(.Keys)
'    Range("B2").Resize(5) = Application.Transpose(.Items)
    Range("A2").Resize(.Count) = Application.Transpose(.Keys)
    Range("B2").Resize(.Count) = Application.Transpose(.Items)
    '[a1].sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
    'fj = Application.Max(.Keys)
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    'Sal = Application.WorksheetFunction.VLookup(fj, Range("A2:B" & lr), 2, False)
    'MsgBox "Ìàêñèìàëüíîå çíà÷åíèå ñðåäè ôàéëîâ:" & vbNewLine & Application.Max(.Keys) & " â " & Sal
    
    End With
    

    
    
    
  
End Sub

Sub sort()

        Open fsoFile For Input As #1
        Dim s As String
        Dim m, k
        
        While Not EOF(1)
            Input #1, s
            On Error Resume Next
            
            m = (CatchNum(s))
          
            'm = Int(Left(s, 10))
            'm = Split((Split(s, " ")(0)), ",")(1)
            'm = Int(Left(Split(s, ",")(1), 3))
            
            dict.Add m, fsoFile.Name
        Wend
        
        Close #1
        
End Sub

Sub SortDictionary(dict As Object)

    Dim i As Long
    
    With CreateObject("System.Collections.SortedList")
        For Each key In dict
        On Error Resume Next
            .Add key, dict(key)
        Next
        dict.RemoveAll

        For i = 0 To .Keys.Count - 1
            dict.Add .GetKey(i), .Item(.GetKey(i))
        Next
        
    End With
End Sub
Function CatchNum(s As String) As Long
    Dim objRegExp, SubobjMatches
        Set objRegExp = CreateObject("VBScript.RegExp")
        objRegExp.Global = True
        objRegExp.Pattern = "1037604"
        'objRegExp.Pattern = "[^,]+,([\d]+)"
        Set SubobjMatches = objRegExp.Execute(s)
        CatchNum = SubobjMatches(0).Value
End Function
[/vba]

Но это мертвая процедура
Файлов бывает 300 штук, каждый по 5 кб txt Строк может быть и 20000

Есть ли возможности оптимизации?

Если раньше искал по паттерну, то теперь просто хочу найти по значению.
В принципе, могу просто убрать процедуру с регулярными выражениями. Но насколько это ускорит, не знаю.
Хотелось бы услышать и увидеть варианты оптимизации для этой задачи на Excel.

Неужели Excel не подходит для больших данных...

Автор - ant6729
Дата добавления - 09.01.2019 в 22:43
vikttur Дата: Среда, 09.01.2019, 23:16 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 2808
Репутация: 504 ±
Замечаний: 0% ±

Без обратной связи помогать - как в стенку... Подошло, не подошло, подправить, пожелания... Вы в своих темах отписываться думаете?


Сообщение отредактировал vikttur - Среда, 09.01.2019, 23:20
 
Ответить
СообщениеБез обратной связи помогать - как в стенку... Подошло, не подошло, подправить, пожелания... Вы в своих темах отписываться думаете?

Автор - vikttur
Дата добавления - 09.01.2019 в 23:16
ant6729 Дата: Среда, 09.01.2019, 23:24 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 519
Репутация: 2 ±
Замечаний: 40% ±

Excel 2010
Ну, конечно, собираюсь)
 
Ответить
СообщениеНу, конечно, собираюсь)

Автор - ant6729
Дата добавления - 09.01.2019 в 23:24
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Найти текст и при его наличии вывести название файла (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2019 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!