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 对象，这是下面的小示例（但没有排序 venicles，我认为这对您来说很容易）。

所以我的输入是：

基于字典的解决方案：

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. 将字典中唯一的“车辆”存储到VehicleArr 数组中。

5. 将VehicleArr 数组按其字符串值排序（从小到大）。

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

---

Worksheet_Change Code（“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

---

子过滤器地址代码（常规模块）

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