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

Question

我想知道是否有人可以帮助我。 我有一堆包含几千行的文本文件，我只想提取每个文件的一个元素。

文件内容的sn-p是这样的：

                    <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