改进/优化Excelmacros以search文本文件夹中的文本短语

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

我发现了一些更好的macros来完成macros的每个部分 – 例如枚举一个目录，或者在一个文本文件中find一个短语 – 尽pipe我很难将它们放在一起。 尽pipe不够完善，但对于同样存在问题的其他人可能会有所帮助，希望能对如何改进和优化macros观提供一些反馈意见。

基本概述：

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

需要改进的方面：

1. 让macros运行更快！ （这360个报告和1100个短语花了一个多小时）
2. 从popup式窗口或其他function中select报告和报告文件夹（当前使用另一个macrosinput到电子表格中）
3. 按文件名过滤报告（例如，只检查文件名中带有单词或短语的报告）
4. 按文件扩展名筛选报告（例如，只检查.txt文件而不检查.xlsx文件）
5. 检测报告和短语的数量（目前这是硬编码）
6. 其他build议/改进的地方

码：

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.沿着相同的路线，让我们创build一次FileSystemObject，而不是每个文件打开一次。

另外，VBA在读取/写入Excel数据时的速度令人惊讶。 我们可以通过使用类似的代码一次性将大量的数据加载到VBA中来处理这个问题

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

然后把它写回像Excel这样的大块

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

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

注意：下面的代码没有经过testing。 此外，它还需要引用FileSystemObjects的“Microsoft脚本运行时”。

 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