excel - 从文本文件 VBA 中提取数据，其中该行包含特定字符串

Question

我想知道是否有人可以帮助我。
我有一堆包含几千行的文本文件，我只想提取每个文件的一个元素。
文件内容的片段如下所示:

                    <LastMassUpdateChange xsi:nil="true" />
                    <Notes />
                    <PropertyType1>House</PropertyType1>
                    <PropertyType2>SemiDetached</PropertyType2>
                    <PositionOfFlat xsi:nil="true" />
                    <FlatWhichFloor>0</FlatWhichFloor>
                    <FlatFloorsAbove>0</FlatFloorsAbove>

我只想提取 <PropertyType2> 之间的文本& </PropertyType2>所以在这种情况下 SemiDetached并将此结果放在文件 url 列旁边。
文件的 url 都将在 excel 中的一列中，因此我需要一个循环 vba 来检查该列中的每个文本文件，并将结果放在下一列中。
我有下面的代码来提取某一行中的数据，但我没有意识到这些文件并非都用相同数量的行格式化，所以它没有解决。
非常感谢任何帮助，谢谢。

Sub extractpropertytype()
Dim d As Integer
' For d = 1 To Sheet2.Range("G" & Rows.Count).End(xlUp).Row
 For d = 2 To Range("AE1").Value + 1
 
 'Workbooks("Book1").Activate
 Open Range("AA" & d).Value For Input Access Read As #1
 For i = 1 To 80

 Line Input #1, X
 'Range("a1").Offset(i - 1, 0).Value = x
 Next i
 Line Input #1, X
 Range("AB" & d) = X
 Close #1
 
 Next d
End Sub

Answer 1

这将使用 file system object 将所有行读入字符串。和 regular expression提取标签之间的值。

Option Explicit

Sub extractpropertytype()

    Dim wb As Workbook, ws As Worksheet
    Dim iRow As Long, iLastRow As Long
    Dim sXML As String, sFilename As String, sPath As String
   
    Dim Regex As Object, Match As Object
    Set Regex = CreateObject("vbscript.regexp")

    ' capture text between tags
    With Regex
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = "<PropertyType2>(.*)</PropertyType2>"
    End With
   
    ' file system object to read text
    Dim oFSO As Object, oFile As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    Set wb = ThisWorkbook
    Set ws = Sheet2 ' change to suit
    sPath = wb.Path & "\"
   
    ' scan list of text files on turn
    iLastRow = ws.Range("AE1").Value + 1
    For iRow = 2 To iLastRow
      
       ' open file and read all lines
       sFilename = sPath & ws.Cells(iRow, "AA")
       Set oFile = oFSO.OpenTextFile(sFilename, 1)
       sXML = oFile.ReadAll
      
       ' extract value with regex
       If Regex.test(sXML) Then
           Set Match = Regex.Execute(sXML)
           ws.Cells(iRow, "AB") = Match(0).submatches(0)
       Else
           ws.Cells(iRow, "AB") = "No match"
       End If
      
       oFile.Close
      
    Next iRow
    MsgBox iLastRow - 1 & " files scanned", vbInformation

End Sub