如何提取用过滤器分隔的excel单元格值？

Question

在列中的每个单元格中，我在单元格中都有此信息：

A1值：

Depth=standard;Size=1 section;Doors=hinged solid;Interior configuration=shelves;Compressor HP=1/2 HP;Interior finish=stainless steel;Exterior finish=stainless steel;Refrigeration=top mount self-contained

A2值：

Top openings= 6 pan;Size=1 section;Compressor HP=1/6 HP;Style=drawers;Exterior finish=stainless steel;Interior finish=stainless steel;Refrigeration=rear mounted

A3，A4，A5等都遵循类似的格式

我需要一些方法将以下信息抽象到自己的单元格中：

如果已经有一个列名，我需要检查每个分号分隔值，如果没有，请创建一个新列并将所有相应的值放在需要的位置

我考虑过使用text-＆gt;列然后使用索引/匹配，但我无法让我的匹配条件正常工作。是为每个独特的专栏做这个。或者我需要使用VBA吗？

Answer 1

你可以选择这样的东西，虽然你必须更新工作表名称，可能还要更新你想要的最终数据。

Sub SplitCell()
    Dim DataFromCell, FoundCell
    Dim Testing, Counted, LastCol
    For Each c In Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
        Testing = Split(c.Value, ";")
        Range("B" & c.row + 1).Value = "A" & c.row
        Counted = UBound(Testing)
        For Each x In Testing
            DataFromCell = Split(x, "=")
            With Sheet2
                Set FoundCell = .Cells.Find(What:=DataFromCell(0), after:=.Cells(1, 2), _
                    LookIn:=xlValues, lookat:=1, searchorder:=xlByColumns, searchdirection:=xlNext, _
                    MatchCase:=False, searchformat:=False)
            End With
            If Not FoundCell Is Nothing Then
                Cells(c.row + 1, FoundCell.Column).Value = DataFromCell(1)
            End If
            If FoundCell Is Nothing Then
                LastCol = Sheet2.Cells(1, Sheet2.Columns.count).End(xlToLeft).Column
                Cells(1, LastCol + 1).Value = DataFromCell(0)
                Cells(c.row + 1, LastCol + 1).Value = DataFromCell(1)
            End If
        Next x
    Next c
End Sub

修改

由于上面给出了错误，你可以试试这个：

Sub SplitCell()
    Dim DataFromCell, FoundCell
    Dim Testing, Counted, LastCol
    For Each c In Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
        Testing = Split(c.Value, ";")
        Range("B" & c.row + 1).Value = "A" & c.row
        Counted = UBound(Testing)
        For Each x In Testing
            DataFromCell = Split(x, "=")
            LastCol = Sheet2.Cells(1, Sheet2.Columns.count).End(xlToLeft).Column
            With Sheet2
                FoundCell = Application.Match(DataFromCell(0), Range(Cells(1, 2), Cells(1, LastCol)), 0)
                'Set FoundCell = .Cells.Find(What:=DataFromCell(0), after:=.Cells(1, 2), _
                    LookIn:=xlValues, lookat:=1, searchorder:=xlByColumns, searchdirection:=xlNext, _
                    MatchCase:=False, searchformat:=False)
            End With
            If Not IsError(FoundCell) Then
                Cells(c.row + 1, FoundCell + 1).Value = DataFromCell(1)
            End If
            If IsError(FoundCell) Then

                Cells(1, LastCol + 1).Value = DataFromCell(0)
                Cells(c.row + 1, LastCol + 1).Value = DataFromCell(1)
            End If
        Next x
    Next c
End Sub

仅更改了一些内容，以便使用Match代替Find

Answer 2

我的解决方案按预期工作，但数据不像我原先想的那样格式化。

Option Explicit

Private Sub Auto_Open()

MsgBox ("Welcome to the delimiter file set.")


End Sub

'What this program does:
'http://i.imgur.com/7MVuZLt.png

Sub DelimitFilter()

Dim curSpec As String
Dim curSpecArray() As String
Dim i As Integer, IntColCounter As Integer, iCounter As Integer, argCounter As Integer
Dim WrdString0 As String, WrdString1 As String
Dim dblColNo As Double, dblRowNo As Double

Worksheets(1).Activate

'Reference to cell values that always have data associated to them
Range("W2").Activate

'checks for number of arguments to iterate through later
Do

    If ActiveCell.Value = "" Then Exit Do
    ActiveCell.Offset(1, 0).Activate
    argCounter = argCounter + 1

Loop

'Check # of arguments
Debug.Print (argCounter)

'Values to delimit
Range("X2").Activate
IntColCounter = 1

'Loop each row argument
For iCounter = 0 To argCounter

    'Set var to activecell name
    dblColNo = ActiveCell.Column
    dblRowNo = ActiveCell.Row

    'Grab input at active cell
    curSpecArray() = Split(ActiveCell.Value, ";")

    'Ignore empty rows
    If Not IsEmpty(curSpecArray) Then

        'Iterate every delimited active cell value at that row
        For i = LBound(curSpecArray) To UBound(curSpecArray)

            'Checks for unique attribute name, if none exists, make one
            WrdString0 = Split(curSpecArray(i), "=")(0)

            'a large range X1:ZZ1 is used as there are many unique column names
            If IsError(Application.Match(WrdString0, Range("X1:ZZ1"), 0)) Then  'if NOT checks if value exists
                Cells(1, dblColNo + IntColCounter).Value = WrdString0
                IntColCounter = IntColCounter + 1
            End If

            'Output attribute value to matching row and column
            WrdString1 = Trim(Split(curSpecArray(i), "=")(1))
            Debug.Print (WrdString1)
            Cells(dblRowNo, -1 + dblColNo + Application.Match(WrdString0, Range("X1:ZZ1"), 0)).Value = WrdString1


        Next i

    End If

    'Iterate Next row value
    ActiveCell.Offset(1, 0).Activate

Next iCounter

End Sub