Excel VBA：使用Excel中的公式或macros从多个逗号分隔的string中提取子string

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中input“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 Basicmacros来执行此操作？

Answer 1

菲尔，你可以使用Dictionary对象，因为它是在评论中提到的，这里是一个小例子下面（但没有sortingvenicles，我认为这将是容易的）。

所以我的意见是：

基于字典的解决scheme：

 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 

我的输出是（不sortingvenicles）：

干杯!

Answer 2

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

在Excel 2010中，可以在“数据”选项卡下的function区上find它

您select要分割的列，在这种情况下，将是“列B”，然后单击function区中的“文本到列”button。

这将打开一个向导，指导您完成整个过程。在第一个屏幕上，您将select“分隔”，因为您已经声明了逗号分隔的string，在第二个屏幕上，在分隔符标题下select逗号。 第三个屏幕允许您select列数据格式（常规，文本，date）

一旦你点击完成，它会分离出选定的列。 您可以复制结果，然后使用“粘贴特殊”和转置将它们粘贴到新区域 – 这将交换多列数据到多行。

Answer 3

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

过程/代码步骤 ：

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

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

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

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

5. 按照它们的string值（ VehicleArr到大）对VehicleArr数组进行sorting。

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 Code （常规模块）

 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