Question

我希望有人可以帮我解决VBA Excel宏问题我收到了Excel 2007中的工作表，其中包含一列中的产品名称，我需要将其排序为逻辑格式，以便我可以使用它。但是，列表本身没有任何逻辑顺序，长达10 000行，我每个月都要这样做!!

基本上，我想要做的是搜索大多数条目共有的某些关键字，并将它们移动到不同列中的单独单元格中（但与原始条目位于同一行中）。

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

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

如果这不够复杂，那么测量（例如cm）在某些情况下是重复的并且是重要的细节，所以我不能将它们分开，但理想情况下它们会在两个相邻的单元格中相似。

幸运的是，每个度量后面都有一个空格，％符号和项目材料。

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

因此，下面是一个示例字符串，假设这是在单元格A1中。（倒置的逗号不包含在字符串中，单词“by”只出现在大约100个案例中。通常它会丢失...）

“椅腿木100％1m乘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

无法保证10k行的速度很快。

解析和比较复杂的字符串

3 个答案: