如何将文本文件中的特定单词提取到 xls 电子表格中

Question

我是 VBA 新手。在这里发布我的问题之前，我花了将近 3 天的时间上网。

我有 300 多个文本文件（使用 OCR 从 PDF 转换的文本），来自文本文件。我需要获取所有包含“字母”和“数字”的单词（例如 KT315A、KT-315-a 等）以及源参考（txt 文件名）。

我需要的是

1.添加“智能过滤器”，仅复制包含
的单词 “字母”和“数字”

1. 将复制的数据粘贴到 A 列

2. 将参考文件名添加到 B 列

我发现下面的代码可以将文本文件中的所有数据复制到 Excel 电子表格中。

文本文件看起来像

“从 252A-552A 到 ddddd, ,,, @,@,rrrr, 22 , ....kt3443 , fff,,,etc 的行”

xls 的最终结果应该是

一个 |乙

252A-552A |文件 1

kt3443 |文件1

 Option Explicit


Const sPath = "C:\outp\" 'remember end backslash
Const delim = "," 'comma delimited text file - EDIT
'Const delim = vbTab  'for TAB delimited text files


Sub ImportMultipleTextFiles()
   Dim wb As Workbook
   Dim sFile As String
   Dim inputRow As Long

   RefreshSheet

   On Error Resume Next
   sFile = Dir(sPath & "*.txt")

   Do Until sFile = ""
      inputRow = Sheets("Temp").Range("A" & Rows.Count).End(xlUp).Row + 1

      'open the text file
'format=6 denotes a text file
      Set wb = Workbooks.Open(Filename:=sPath & sFile, _
         Format:=6, _
         Delimiter:=delim)

      'copy and paste
      wb.Sheets(1).Range("A1").CurrentRegion.Copy _
         Destination:=ThisWorkbook.Sheets("Temp").Range("A" & inputRow)
      wb.Close SaveChanges:=False

      'get next text file
      sFile = Dir()
   Loop

   Set wb = Nothing
End Sub


Sub RefreshSheet()
   'delete old sheet and add a new one
   On Error Resume Next

   Application.DisplayAlerts = False
      Sheets("Temp").Delete
   Application.DisplayAlerts = True

   Worksheets.Add
   ActiveSheet.Name = "Temp"

   On Error GoTo 0
End Sub

谢谢！

Answer 1

从您的示例中准确说出单词的构成有点困难。它显然可以包含字母和数字以外的字符（例如破折号），但有些项目前面有点，因此不能定义为由space 分隔。

我将“单词”定义为一个字符串

• 以字母或数字开头，以字母或数字结尾
• 同时包含字母和数字
  • 可能还包含除逗号以外的任何其他非空格字符

为此，我首先将所有逗号替换为空格，然后应用适当的正则表达式。但是，这可能会接受不需要的字符串，因此您可能需要更具体地准确定义什么是单词。

此外，通过使用FileSystemObject，我们可以一次处理一行，而不是将整个文件读入 Excel 工作簿，而无需将 300 个文件读入 Excel。与您一样，基本文件夹由 VBA 代码中的常量设置。

但还有其他方法可以做到这一点。

请务必按照代码中的说明设置早期绑定的引用：

---

Option Explicit
'Set References to:
'  Microsoft Scripting Runtime
'  Microsoft VBscript Regular Expressions 5.5

Sub SearchMultipleTextFiles()
    Dim FSO As FileSystemObject
    Dim TS As TextStream, FO As Folder, FI As File, FIs As Files
    Dim RE As RegExp, MC As MatchCollection, M As Match

    Dim WS As Worksheet, RW As Long

    Const sPath As String = "C:\Users\Ron\Desktop"

Set FSO = New FileSystemObject
Set FO = FSO.GetFolder(sPath)

Set WS = ActiveSheet
    WS.Columns.Clear

Set RE = New RegExp
With RE
    .Global = True
    .Pattern = "(?:\d(?=\S*[a-z])|[a-z](?=\S*\d))+\S*[a-z\d]"
    .IgnoreCase = True
End With

For Each FI In FO.Files
    If FI.Name Like "*.txt" Then
        Set TS = FI.OpenAsTextStream(ForReading)
        Do Until TS.AtEndOfStream

            'Change .ReadLine to .ReadAll *might* make this run faster
            ' but would need to be tested.
            Set MC = RE.Execute(Replace(TS.ReadLine, ",", " "))
            If MC.Count > 0 Then
                For Each M In MC
                    RW = RW + 1
                    WS.Cells(RW, 1) = M
                    WS.Cells(RW, 2) = FI.Name
                Next M
            End If
        Loop
    End If
Next FI

End Sub

---