Question

使用Microsoft Excel 2010，此宏搜索文本报告文件夹中的短语列表。对于每个短语，它会搜索所有报告并列出包含短语的每个报告。

我找到了一些更好的宏来执行宏的每个部分 - 例如枚举目录或在文本文件中查找短语 - 尽管我很难将它们成功地组合在一起。尽管它不完美，但对于遇到同样问题的其他人可能会有所帮助，我希望能就如何改进和优化宏来提供一些反馈。

基本概述：

A列：文本报告的完整路径列表（例如，＆＃34; C：\ path \ to \ report.txt＆＃34;）
B列：报告名称（例如＆＃34; report.txt＆＃34;）
C列：要搜索的短语列表
列D +：显示包含短语（C列）的每个报告的输出

需要改进的地方：

让宏运行得更快！（360个报告和1100个短语花了一个多小时）
从弹出窗口或其他功能中选择报告和报告文件夹（当前使用其他宏输入电子表格）
按文件名过滤报告（例如，仅检查文件名中包含单词或短语的报告）
按文件扩展名过滤报告（例如，只检查.txt文件而非.xlsx文件）
检测报告和短语的数量（目前这是硬编码的）
其他建议/需要改进的地方

代码：

Sub findStringMacro()

Dim fn As String
Dim lineString As String
Dim fileName As String
Dim searchTerm As String
Dim findCount As Integer
Dim i As Integer
Dim j As Integer

For i = 2 To 1109
searchTerm = Range("C" & i).Value
findCount = 0
    For j = 2 To 367
    fn = Range("A" & j).Value
    fileName = Range("B" & j).Value
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(fn)
        Do While Not .AtEndOfStream
            lineString = .ReadLine
            If InStr(1, lineString, searchTerm, vbTextCompare) Then
                findCount = findCount + 1
                Cells(i, 3 + findCount) = fileName
                GoTo EarlyExit
            End If
        Loop
EarlyExit:
        .Close        
    End With
    Next j    
Next i
End Sub

Answer 1

正如@Makah指出的那样，你打开了很多文件，这很慢。要解决此问题，请更改循环的顺序（请参阅下面的代码）。这将从407,003文件打开切换到367.沿着相同的行，让我们创建一次FileSystemObject，而不是每个文件打开一次。

此外，VBA在从/向Excel读取/写入数据时出乎意料地缓慢。我们可以通过使用类似

之类的代码将largw数据块一次性加载到VBA中来解决这个问题

dim data as Variant
data = Range("A1:Z16000").value

然后在像

这样的大块中将其写回Excel

Range("A1:Z16000").value = data

我还在代码中添加了动态检查数据维度的代码。我们假设数据在单元格A2中开始，如果A3为空，我们使用单个单元格A2。否则，我们会使用.End(xlDown)向下移动到列A中第一个空单元格的上方。这相当于按ctrl+shift+down。

注意：以下代码尚未经过测试。此外，它需要引用＆＃34; Microsoft Scripting Runtime＆＃34;对于FileSystemObjects。

Sub findStringMacro()
    Dim fn As String
    Dim lineString As String
    Dim fileName As String
    Dim searchTerm As String
    Dim i As Integer, j As Integer

    Dim FSO As Scripting.FileSystemObject
    Dim txtStr As Scripting.TextStream
    Dim file_rng As Range, file_cell As Range

    Dim output As Variant
    Dim output_index() As Integer

    Set FSO = New Scripting.FileSystemObject

    Set file_rng = Range("A2")
    If IsEmpty(file_rng) Then Exit Sub
    If Not IsEmpty(file_rng.Offset(1, 0)) Then
        Set file_rng = Range(file_rng, file_rng.End(xlDown))
    End If

    If IsEmpty(Range("C2")) Then Exit Sub
    If IsEmpty(Range("C3")) Then
        output = Range("C2")
    Else
        output = Range(Range("C2"), Range("C2").End(xlDown))
    End If

    ReDim Preserve output(1 To UBound(output, 1), 1 To file_rng.Rows.Count + 1)
    ReDim output_index(1 To UBound(output, 1))
    For i = 1 To UBound(output, 1)
        output_index(i) = 2
    Next i

    For Each file_cell In file_rng
        fn = file_cell.Value    'Range("A" & j)
        fileName = file_cell.Offset(0, 1).Value 'Range("B" & j)
        Set txtStr = FSO.OpenTextFile(fn)
        Do While Not txtStr.AtEndOfStream
            lineString = txtStr.ReadLine
            For i = 1 To UBound(output, 1)
                searchTerm = output(i, 1)   'Range("C" & i)
                If InStr(1, lineString, searchTerm, vbTextCompare) Then
                    If output(i, output_index(i)) <> fileName Then
                        output_index(i) = output_index(i) + 1
                        output(i, output_index(i)) = fileName
                    End If
                End If
            Next i
        Loop
        txtStr.Close
    Next file_cell

    Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output

    Set txtStr = Nothing
    Set FSO = Nothing
    Set file_cell = Nothing
    Set file_rng = Nothing
End Sub

改进/优化Excel宏以在文本报告的文件夹中搜索文本短语

1 个答案: