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

Question

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

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

基本概述：

1. A 列：文本报告的完整路径列表（例如，“C:\path\to\report.txt”）
2. B 列：报告名称（如“report.txt”）
3. C 列：要搜索的短语列表
4. D+ 列：输出显示包含短语的每个报告（C 列）

需要改进的地方：

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

代码：

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 读取数据/向 Excel 写入数据方面速度非常慢。我们可以通过使用类似

的代码一次性将大块数据加载到 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。

注意：以下代码未经测试。此外，它需要对 FileSystemObjects 的“Microsoft Scripting Runtime”的引用。

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