Question

我们说我有一个带有以下内容的字符串str_content（是的，因为我正在阅读文件，所以有断行）：

str_content = "PRODUCT label = 'Equipment XS'
equipment size = 9.75 wt = 0.5 quality = 0.001969
rent dist = 0 index = 40.774278 tp = 48
rent dist = 50 index = 0 tp = 48
rent dist = 130 index = 0 tp = 60"

VBA中的一个函数如何通过使用它来获取我想要的值？

extract_data(str_content, "PRODUCT label") = Equipment XS
extract_data(str_content, "wt") = 0.5
extract_data(str_content, "quality") = 0.001969

不仅如此，还要经历＆＃34;租赁＆＃34;这样的部分：

extract_data(str_content, rent(0), “index”) = 40.774278
extract_data(str_content, rent(0), “tp”) = 48
extract_data(str_content, rent(0), “dist”) = 0
extract_data(str_content, rent(1), “index”) = 0
extract_data(str_content, rent(1), “tp”) = 48
extract_data(str_content, rent(1), “dist”) = 50
extract_data(str_content, rent(2), “index”) = 0
extract_data(str_content, rent(2), “tp”) = 60
extract_data(str_content, rent(2), “dist”) = 130

有专家知道吗？我不是一个IT人员，所以这将有助于我在Excel中做的很多工作。

Answer 1

请尝试以下代码：

Option Explicit

Sub Test()

    Dim sData As String
    Dim oData As Object

    ' Read data from file
    sData = ReadTextFile(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\sample.txt", -1)
    ' Parse text data to structured nested dictionaries
    Set oData = ParseData(sData)
    ' Test
    Debug.Print oData("PRODUCT")(0)("label")
    Debug.Print oData("equipment")(0)("size")
    Debug.Print oData("equipment")(0)("wt")
    Debug.Print oData("equipment")(0)("quality")
    Debug.Print oData("rent")(0)("dist")
    Debug.Print oData("rent")(0)("index")
    Debug.Print oData("rent")(0)("tp")
    Debug.Print oData("rent")(1)("dist")
    Debug.Print oData("rent")(1)("index")
    Debug.Print oData("rent")(1)("tp")
    Debug.Print oData("rent")(2)("dist")
    Debug.Print oData("rent")(2)("index")
    Debug.Print oData("rent")(2)("tp")

End Sub

Function ParseData(sContent As String) As Object

    Dim spN As String
    Dim spQ As String
    Dim sDelim As String
    Dim aSections
    Dim oSections As Object
    Dim aSection
    Dim aParams
    Dim oSection As Object
    Dim i As Long
    Dim sParam
    Dim aValues
    Dim v

    spN = "[+-]?(?:\d+\.\d*|\.\d+|\d+)(?:e[+-]?\d+)?" ' pattern for number
    spQ = "'[^']*'|""(?:\\""|[^""])*""" ' pattern for quoted string
    sDelim = Mid(1 / 2, 2, 1) ' regional decimal delimiter
    ' Extract each section
    ParseResponse "^([\w ]*?)((?: \w* ?\= ?(?:" & spN & "|" & spQ & "))+)$", sContent, aSections, False
    ' aSections - sections array
    ' Create dictionary for sections
    Set oSections = CreateObject("Scripting.Dictionary")
    ' Process each section
    For Each aSection In aSections
        ' aSection - section array
        ' aSection(0) - section name
        ' aSection(1) - section content
        ' Extract each parameter
        ParseResponse "(\w* ?\= ?(?:" & spN & "|" & spQ & "))", aSection(1), aParams, False
        ' aParams - parameters array
        ' Create dictionary for current section entries if not exists
        If Not oSections.Exists(aSection(0)) Then Set oSections(aSection(0)) = CreateObject("Scripting.Dictionary")
        ' Current section entries
        Set oSection = oSections(aSection(0))
        ' Current section entry index
        i = oSection.Count
        ' Create new section entry and dictionary for parameters
        Set oSection(i) = CreateObject("Scripting.Dictionary")
        ' Process each parameter
        For Each sParam In aParams
            ' sParam - parameter string
            ' Extract values
            ParseResponse "(\w*) ?\= ?(?:(" & spN & ")|(" & spQ & "))", sParam, aValues, False, False
            ' aValues - name and value array
            ' aValues(0) - parameter name
            ' aValues(1) - parameter numeric value
            ' aValues(2) - parameter string value
            ' Evaluating value as number or string
            If IsEmpty(aValues(2)) Then ' Number
                v = CDbl(Replace(aValues(1), ".", sDelim))
            Else ' Quoted string
                v = Mid(aValues(2), 2, Len(aValues(2)) - 2)
            End If
            ' Assign value to section entry parameter name
            oSection(i)(aValues(0)) = v
        Next
    Next
    Set ParseData = oSections

End Function

Sub ParseResponse(sPattern, sResponse, aData, Optional bAppend As Boolean = True, Optional bNestSubMatches = True, Optional bGlobal = True, Optional bMultiLine = True, Optional bIgnoreCase = True)

    Dim oMatch
    Dim aTmp0()
    Dim sSubMatch

    If Not (IsArray(aData) And bAppend) Then aData = Array()
    With CreateObject("VBScript.RegExp")
        .Global = bGlobal
        .MultiLine = bMultiLine
        .IgnoreCase = bIgnoreCase
        .Pattern = sPattern
        For Each oMatch In .Execute(sResponse)
            If oMatch.SubMatches.Count = 1 Then
                PushItem aData, oMatch.SubMatches(0)
            Else
                If bNestSubMatches Then
                    aTmp0 = Array()
                    For Each sSubMatch In oMatch.SubMatches
                        PushItem aTmp0, sSubMatch
                    Next
                    PushItem aData, aTmp0
                Else
                    For Each sSubMatch In oMatch.SubMatches
                        PushItem aData, sSubMatch
                    Next
                End If
            End If
        Next
    End With

End Sub

Sub PushItem(aData, vItem, Optional bAppend As Boolean = True)

    If Not (IsArray(aData) And bAppend) Then aData = Array()
    ReDim Preserve aData(UBound(aData) + 1)
    aData(UBound(aData)) = vItem

End Sub

Function ReadTextFile(sPath As String, lFormat As Long) As String

    ' lFormat -2 - System default, -1 - Unicode, 0 - ASCII
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath, 1, False, lFormat)
        ReadTextFile = ""
        If Not .AtEndOfStream Then ReadTextFile = .ReadAll
        .Close
    End With

End Function

为了进行测试，我在桌面上将文件sample.txt保存为Unicode，内容为：

PRODUCT label = 'Equipment XS'
equipment size = 9.75 wt = 0.5 quality = 0.001969
rent dist = 0 index = 40.774278 tp = 48
rent dist = 50 index = 0 tp = 48
rent dist = 130 index = 0 tp = 60

我的输出如下：

搜索字符串（VBA）中由等号指定的多个值

1 个答案: