解析和比較復雜的字符串

Question

我希望有人可以通過VBA Excel宏幫助我。
我已經在Excel 2007中收到一個工作表，該工作表的一欄中包含產品名稱，我需要將其排序為邏輯格式，以便可以使用它。 但是，列表本身並不是任何邏輯順序，它的長度為10000行，我每個月都必須這樣做！！

基本上，我想做的是搜索大多數條目通用的某些關鍵字，並將它們移到不同列（但與原始條目位於同一行）中的單獨單元格中。

關於關鍵字：有3種不同的類型，其中有2種是我的完整列表。

關鍵字示例：一些度量，例如cm（厘米），mm（毫米），m（米）等）。 然后是其他關鍵字，例如％，最后是木材，塑料，玻璃等的最后一組關鍵字。

如果這還不夠復雜，那么在某些情況下，度量（例如cm）是重復的，並且是重要的細節，因此我不能將它們分開，但是理想情況下，它們會喜歡在兩個相鄰的單元格中。

幸運的是，每個小節，％符號和項目材料后面都有一個空格。

從右到左工作是我想到的最簡單的方法，因為字符串中的第一個描述在條目之間千差萬別，並且可以保持不變。

因此，下面是一個示例字符串，可以說這是在Cell A1中。 （字符串中不包含反逗號，並且“ by”一詞僅在大約100種情況下出現。通常會丟失...）

“椅子腿木100％1m x 20cm”

我理想情況下希望將字符串分成以下單元格

Cell B1 - Chair Leg  
Cell C1 - Wood  
Cell D1 - 1m  
Cell E1 - 2cm  
Cell F1 - 100%  

在同一列中包含％度量將非常有幫助

任何人都可以幫我解決這個問題，或者可以幫我做一個宏的開始，然后將其移到列表的下方-我試過使用一些基本的“查找”和“ len”公式，但實際上我的智慧是如何解決這個問題的！

Answer 1

任務歸結為定義輸入數據結構的可靠定義。

表單中提供的候選定義可能是

<Description, one or more words> <Material, one word> <A value followd by %> <Dimension A> <optional "by">  <Dimension B>

以下宏將處理符合此規范的數據。 該定義可能需要擴展，例如兩種文字材料（例如低碳鋼）

如果任何行不符合要求，您將需要添加錯誤處理，例如，字符串中沒有％或字符串中其他地方的％字符

Option Explicit

Dim dat As Variant

Sub ProcessData()
    Dim r As Range
    Dim i As Long

    Set r = Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns(1)).Resize(, 5)
    dat = r
    For i = 1 To UBound(dat, 1)
        ParseRow i, CStr(dat(i, 1))
    Next
    r = dat
    ActiveSheet.Columns(5).Style = "Percent"

End Sub


Sub ParseRow(rw As Long, s As String)
    'Chair Leg Wood 100% 1m by 20cm

    Dim i As Long
    Dim sDim As String, sPCnt As String, sMat As String, sDesc As String
    Dim sA As String, sB As String

    i = InStr(s, "% ")
    sDim = Trim(Replace(Mid(s, i + 2), " by ", " "))  ' text to right of %, remove "by"
    sA = Trim(Left(sDim, InStr(sDim, " ")))           ' split dimension string in two
    sB = Trim(Mid(sDim, InStr(sDim, " ")))
    s = Left(s, i)

    i = InStrRev(s, " ")
    sPCnt = Mid(s, i + 1)        ' text back to first space before %
    s = Trim(Left(s, i))  

    i = InStrRev(s, " ")         ' last word in string
    sMat = Mid(s, i + 1)
    sDesc = Trim(Left(s, i))     ' whats left


    dat(rw, 1) = sDesc
    dat(rw, 2) = sMat
    dat(rw, 3) = sA
    dat(rw, 4) = sB
    dat(rw, 5) = sPCnt

End Sub

Answer 2

首先，我將使用Split函數將各部分分成一個數組，這將避免大多數字符串函數和字符串數學運算：

Dim parts As Variant
parts = Split(A1)

然后，我將對每個部分進行比較。
最后，我將沒有中斷的部分連接起來，然后將所有部分放置在工作表上。

這是基於您的示例，該示例在每個部分之間都有空格，盡管類似的方法也可以工作，但您只需要對每個部分做更多的工作。

Answer 3

這是我的目的。 我們可以再使用大約10個示例，但這應該是一個開始。 要使用，請在描述中選擇一列范圍，然后運行SplitProduct。 它將拆分到每個單元格的右側。

Sub SplitProducts()

    Dim rCell As Range
    Dim vaSplit As Variant
    Dim i As Long
    Dim aOutput() As Variant
    Dim lCnt As Long

    Const lCOLDESC As Long = 1
    Const lCOLMAT As Long = 2
    Const lCOLPCT As Long = 3
    Const lCOLREM As Long = 4

    If TypeName(Selection) = "Range" Then
        If Selection.Columns.Count = 1 Then
            For Each rCell In Selection.Cells
                'split into words
                vaSplit = Split(rCell.Value, Space(1))
                ReDim aOutput(1 To 1, 1 To 1)

                'loop through the words
                For i = LBound(vaSplit) To UBound(vaSplit)
                    Select Case True
                        Case IsPercent(vaSplit(i))
                            'percents always go in the same column
                            lCnt = lCOLPCT
                            If UBound(aOutput, 2) < lCnt Then
                                ReDim Preserve aOutput(1 To 1, 1 To lCnt)
                            End If
                            aOutput(1, lCnt) = vaSplit(i)
                        Case IsInList(vaSplit(i))
                            'list items always go in the same column
                            lCnt = lCOLMAT
                            ReDim Preserve aOutput(1 To 1, 1 To lCnt)
                            If UBound(aOutput, 2) < lCnt Then
                                ReDim Preserve aOutput(1 To 1, 1 To lCnt)
                            End If
                            aOutput(1, lCnt) = vaSplit(i)
                        Case IsMeasure(vaSplit(i))
                            'measurements go in the last column(s)
                            If UBound(aOutput, 2) < lCOLREM Then
                                lCnt = lCOLREM
                            Else
                                lCnt = UBound(aOutput, 2) + 1
                            End If
                            ReDim Preserve aOutput(1 To 1, 1 To lCnt)
                            aOutput(1, lCnt) = vaSplit(i)
                        Case Else
                            'everything else gets concatentated in the desc column
                            aOutput(1, lCOLDESC) = aOutput(1, lCOLDESC) & " " & vaSplit(i)
                    End Select
                Next i

                'remove any extraneous spaces
                aOutput(1, lCOLDESC) = Trim(aOutput(1, lCOLDESC))

                'write the values to the left of the input range
                rCell.Offset(0, 1).Resize(1, UBound(aOutput, 2)).Value = aOutput

            Next rCell
        Else
            MsgBox "Select a one column range"
        End If
    End If

End Sub

Function IsPercent(ByVal sInput As String) As Boolean

    IsPercent = Right$(sInput, 1) = "%"

End Function

Function IsInList(ByVal sInput As String) As Boolean

    Dim vaList As Variant
    Dim vaTest As Variant

    'add list items as needed
    vaList = Array("Wood", "Glass", "Plastic")
    vaTest = Filter(vaList, sInput)

    IsInList = UBound(vaTest) > -1

End Function

Function IsMeasure(ByVal sInput As String) As Boolean

    Dim vaMeas As Variant
    Dim i As Long

    'add measurements as needed
    vaMeas = Array("mm", "cm", "m")

    For i = LBound(vaMeas) To UBound(vaMeas)
        'any number of characters that end in a number and a measurement
        If sInput Like "*#" & vaMeas(i) Then
            IsMeasure = True
            Exit For
        End If
    Next i

End Function

無法保證這將在1萬行上快速進行。