解析和比较一个复杂的字符串

Question

我希望有人可以帮助我一个VBA Excel宏。
我在Excel 2007中收到一个工作表，其中包含一列中的产品名称，我需要将其分类为逻辑格式，以便我可以使用它。然而，名单本身并没有任何一种逻辑顺序，是10 000行，我将不得不每个月都这样做！

基本上，我想要做的就是搜索某些关键字这是常见的大多数条目，并将其移动到单独的细胞在不同的列（但在同一行原有条目）。

关于关键字：有3种不同类型，其中两个我的完整列表。

关键字的示例：一些是措施，例如（厘米），（毫米），M（米）等）。然后还有其他关键字，例如％，最后是最后一组关键字，这些关键字是木材，塑料，玻璃等。

如果这不够复杂，那么措施（例如厘米）在某些情况下会重复并且很重要因此我不能将它们分开，但理想情况下它们会在两个相邻的单元中使用。

幸运的是，每个度量，％号和项材料之后的空间中。

从右到左的工作是我能想到的实现这一点的字符串中第一个描述的最简单的方法疯狂条目之间变化，并且可以保持原样。

因此，下面是一个示例字符串，可以说这是在Cell A1中。 （不包括字符串和“由”只出现在大约100的情况。通常它缺少字加上引号...）

“椅子腿木100％由20cm蒸发1M”我会非常喜欢的字符串被分裂成细胞如下

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

按相同列％的措施将是非常有益的

任何人都可以请帮我这个或宏的开端，其做到这一点，然后向下移动列表 - 我有尝试使用一些基本的“发现”和“len”公式，但真的在我的智慧结束如何处理这个！

Answer 1

首先，我会使用Split函数的部分分成数组，这将避免大部分的字符串函数和字符串数学：

Dim parts As Variant 
parts = Split(A1) 

然后，我会尽我的比较，每个部分。
最后，我会连接我没有突破的部分，并将所有部分放在工作表上。

这是基于你的榜样具有其间的每一部分空间，但类似的事情可以工作，否则，你就必须做更多的工作，每一个部分。

Answer 2

该任务归结为定义输入数据结构的健壮定义。

表单中的资讯提供的候选定义可能

<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 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 

没有保证，这将在10k行快速。