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

我在第1页上有以下列表：

    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

在表2中，当我在单元格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宏执行此操作的方法？

菲尔，您可以使用注释中提到的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

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

---

干杯

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

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

---

干杯

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

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

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

这将打开一个向导，指导您完成此过程， 在第一个屏幕上，您可以选择“delimited”，正如您所说，您有逗号分隔的字符串，在第二个屏幕上，在Delimiters标题下选择逗号。 第三个屏幕允许您选择列数据格式（常规、文本、日期）

单击“完成”后，它将分离出所选列。

---

您可以复制结果，然后使用“特殊粘贴”和转置将其粘贴到新区域中-这将把数据从多列交换到多行。

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

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

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

这将打开一个向导，指导您完成此过程， 在第一个屏幕上，您可以选择“delimited”，正如您所说，您有逗号分隔的字符串，在第二个屏幕上，在Delimiters标题下选择逗号。 第三个屏幕允许您选择列数据格式（常规、文本、日期）

单击“完成”后，它将分离出所选列。

---

您可以复制结果，然后使用“paste special”和转置将它们粘贴到一个新区域-这将把数据从多列交换到多行。

这个答案有点长，但代码非常简单，有详细的步骤

过程/代码步骤：

代码被放置在

工作表\u Change

事件的“Sheet2”模块中，并检查B列中的值是否被修改（如果需要可以扩展到“B1”的单个单元格），如果被修改，则调用

过滤器地址

子模块，并发送

目标值

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

AutoFilter

使用

特殊单元格（xlCellTypeVisible）

在可见单元格中循环，并使用

字典

对象，仅保留唯一的“车辆”

将字典中唯一的“车辆”存储到

VehicleArr

数组中

按字符串值（从最小到最大）对

Vehiclerr

数组进行排序

根据PO请求将值粘贴到“表2”

---

工作表\u更改代码（“工作表2”模块）

---

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

选项显式
子筛选器地址（FilterVal作为字符串）
最后一排一样长
暗滤器作为范围，单元格作为范围
作为对象的Dim Dict
“暗淡的身份证
变光车辆作为变型
变光车辆
我和我一样长，我和我一样长
附页（“第1页”）
'查找列“A”中数据的最后一行（地址）
LastRow=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
设置filterng=.Range（“A1:B”和LastRow）
.范围（“A1”）.自动过滤器
根据B列“Sheet2”中的值“AutoFilter”Sheet1
FilterRng.AutoFilter字段：=1，准则1:=FilterVal
Set Dict=CreateObject（“Scripting.Dictionary”）
'创建一个最大行数的数组>>将在以后调整其大小
重拨车辆驾驶员（1至最后一排）
j=1'初始阵列计数器
对于.Range（“B2:B”和LastRow）.SpecialCells（xlCellTypeVisible）中的每个单元格
'使用拆分函数从单元格到数组读取值
车辆=拆分（cell.Value，“”）
对于i=LBound（车辆）至UBound（车辆）
车辆（i）=修剪（车辆（i））'从字符串中删除额外的空间
如果不存在指令（车辆（i）），则
添加车辆（i），车辆（i）
“将车辆名称保存到数组>>稍后将用于“气泡排序”并粘贴到“Sheet2”
车辆驾驶员（j）=车辆（i）
j=j+1'增量车辆计数器
如果结束
接下来我
下一个细胞
'根据实际车辆数量调整阵列大小
雷迪姆保护车辆驾驶员（1至j-1）
以
变光车辆MP作为变型
'气泡排序车辆阵列>>将车辆阵列从最小到最大排序
对于i=1至UBound（车辆限制器）-1
对于j=i+1至UBound（车辆驾驶员）
如果车辆驾驶员（j）<车辆驾驶员（i），则
VehicleTmp=车辆驾驶员（j）
车辆驾驶员（j）=车辆驾驶员（i）
车辆驾驶员（i）=车辆驾驶员
如果结束
下一个j
接下来我
'现在“乐趣”部分>>粘贴到“Sheet2”
附页（“第2页”）
.Range（“A1”）.Value=“地址”
.范围（“B1”）.值=过滤器量程
.范围（“C1”）.Value=“使用的车辆”
'清除上一次运行的内容
.Range（“D1:D”和.Cells（.Rows.Count，“D”）.End（xlUp.Row）.ClearContents
.范围（“D1:D”和UBoun
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