Excel VBA：使用Excel中的公式或宏从多个逗号分隔的字符串中提取子字符串

Question

我在Sheet1上有以下列表：

    COLUMN A    COLUMN B
 1  ADDRESS     VEHICLE(S) USED
 2  Address1    Vehicle1, Vehicle3, Vehicle4
 3  Address2    Vehicle1, Vehicle3, Vehicle4
 4  Address3    Vehicle1, Vehicle2, Vehicle5
 5  Address4    Vehicle1, Vehicle6 
 6  Address1    Vehicle2, Vehicle4, Vehicle6 
 7  Address2    Vehicle2, Vehicle3
 8  Address1    Vehicle2, Vehicle5

在Sheet2上，当我在单元格B1中输入“Address1”时，我想在D列中输出以下内容

   COLUMN A    COLUMN B    COLUMN C         COLUMN D
1  ADDRESS     Address 1   VEHICLE(S) USED  Vehicle1
2                                           Vehicle2
3                                           Vehicle3
4                                           Vehicle4
5                                           Vehicle5
6                                           Vehicle6

有没有办法使用visual basic宏执行此操作？

Answer 1

Phil，你可以使用在评论中提到的Dictionary对象，下面是一个小例子（但是没有排序的小片，我觉得你很容易）。

所以我的意见是：

基于字典的解决方案：

Public Sub ExractSubstringsFromBlaBlaBla(ByVal GiveMeAddress As String)
    Dim GatheredStrings As Object
    Dim Addresses As Variant
    Dim VeniclesUsed As Variant
    Dim SubResult() As String
    Dim i As Long
    Dim j As Long

    'Setting up info
    Set GatheredStrings = CreateObject("Scripting.Dictionary")
    Addresses = Sheets(1).[A2:A8].Value2
    VeniclesUsed = Sheets(1).[B2:B8].Value2

    'Gathering dict
    For i = LBound(Addresses) To UBound(Addresses)
        If GiveMeAddress = Addresses(i, 1) Then
            SubResult = Split(Expression:=VeniclesUsed(i, 1), Delimiter:=", ")
            For j = LBound(SubResult) To UBound(SubResult)
                If Not GatheredStrings.Exists(SubResult(j)) Then _
                        Call GatheredStrings.Add(Key:=SubResult(j), Item:=SubResult(j))
            Next
        End If
    Next

    'If dictionary is empty - lets quit
    If GatheredStrings.Count = 0 Then _
            Exit Sub

    Sheets(2).[A1].Value2 = GiveMeAddress
    'Resize and transpose array to fit in vertical direction
    Sheets(2).[B1].Resize(GatheredStrings.Count).Value2 = _
            Application.Transpose(GatheredStrings.Keys)
End Sub

我的输出是（没有排序的小泡）：

干杯!

Answer 2

您可以使用“文本到列”功能以及“转置”复制和粘贴功能来执行此任务。

在Excel 2010中，可以在“数据”选项卡下的功能区上找到它

选择要拆分的列，在本例中为“列B”，然后单击功能区中的“文本到列”按钮。

这将打开一个向导来指导您完成整个过程。在第一个屏幕上，您将选择“分隔”，因为您已声明使用逗号分隔字符串，在第二个屏幕上选择“分隔符”标题下的“逗号”。 第三个屏幕允许您选择列数据格式（常规，文本，日期）

单击完成后，它将分离出所选列。 您可以复制结果，然后使用“粘贴特殊”将其粘贴到新区域并进行转置 - 这会将多列中的数据交换为多行。

Answer 3

这个答案有点长，但代码很简单，步骤很详细。

流程/代码步骤 ：

1. 代码放在Worksheet_Change事件的“Sheet2”模块中，检查B列中的值是否被修改（如果需要可以扩展到单个单元格“B1”），如果它调用FilterAddress Sub，则发送Target.Value 。

2. 根据“Sheet2”中单元格B1中输入的值，在“Sheet1”中使用AutoFilter 。

3. 使用SpecialCells(xlCellTypeVisible)循环显示可见单元格，并使用Dictionary对象，仅保留唯一的“车辆”。

4. 将Dictionary中唯一的“Vehicles”存储到VehicleArr数组中。

5. 按照字符串值（从最小到最大）对VehicleArr数组进行排序。

6. 根据PO请求将值粘贴到“Sheet2”。

---

Worksheet_Change代码 （“Sheet2”模块）

Private Sub Worksheet_Change(ByVal Target As Range)

' call Function only if modifed cell is in Column "B"
If Not Intersect(Target, Range("B:B")) Is Nothing Then
    Application.EnableEvents = False

    Call FilterAddress(Target.Value)
End If

Application.EnableEvents = True

End Sub

---

Sub FilterAddress代码 （常规模块）

Option Explicit

Sub FilterAddress(FilterVal As String)

Dim LastRow As Long
Dim FilterRng As Range, cell As Range
Dim Dict As Object
'Dim ID
Dim Vehicle     As Variant
Dim VehicleArr  As Variant
Dim i As Long, j As Long


With Sheets("Sheet1")
    ' find last row with data in column "A" (Adress)
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    Set FilterRng = .Range("A1:B" & LastRow)

    .Range("A1").AutoFilter
    ' AutoFilter "Sheet1" according to value in "Sheet2" in Column B
    FilterRng.AutoFilter Field:=1, Criteria1:=FilterVal

    Set Dict = CreateObject("Scripting.Dictionary")

    ' create an array with size up to number of rows >> will resize it later
    ReDim VehicleArr(1 To LastRow)
    j = 1 ' init array counter

    For Each cell In .Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)
        ' read values from cell to array using the Split function
        Vehicle = Split(cell.Value, ",")

        For i = LBound(Vehicle) To UBound(Vehicle)
            Vehicle(i) = Trim(Vehicle(i)) ' remove extra spaces from string

            If Not Dict.exists(Vehicle(i)) Then
                Dict.Add Vehicle(i), Vehicle(i)

                ' save Vehicle Name to array >> will use it later for "Bubble-sort" and paste in "Sheet2"
                VehicleArr(j) = Vehicle(i)
                j = j + 1 ' increment VehicleArr counter
            End If
        Next i

    Next cell
    ' resize array up to number of actual Vehicle
    ReDim Preserve VehicleArr(1 To j - 1)

End With

Dim VehicleTmp As Variant
' Bubble-sort Vehicle Array >> sorts the Vehicle array from smallest to largest
For i = 1 To UBound(VehicleArr) - 1
    For j = i + 1 To UBound(VehicleArr)
        If VehicleArr(j) < VehicleArr(i) Then
            VehicleTmp = VehicleArr(j)
            VehicleArr(j) = VehicleArr(i)
            VehicleArr(i) = VehicleTmp
        End If
    Next j
Next i

' now the "fun" part >> paste to "Sheet2"
With Sheets("Sheet2")
    .Range("A1").Value = "ADDRESS"
    .Range("B1").Value = FilterVal
    .Range("C1").Value = "VEHICLE(S) USED"

    ' clear contents from previous run
    .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row).ClearContents
    .Range("D1:D" & UBound(VehicleArr)) = WorksheetFunction.Transpose(VehicleArr)
End With

End Sub