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上，当我输入＆＃34;地址1和＃34;时，我想在D列中输出以下内容。在单元格B1中

   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

菲尔，你可以使用评论中提到的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

您可以使用＆＃39;文本到列＆＃39;功能与也是＆＃39;转置＆＃39;复制和粘贴功能可以完成这项任务。

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

您选择要拆分的列，在这种情况下将是＆＃39; B列＆＃39;然后点击＆＃39;文本到列＆＃39;功能区中的按钮。

这会打开一个向导来指导您完成整个过程，在第一个屏幕上，您可以选择＆＃39;分隔＆＃39;如你所说，你有逗号分隔的字符串，在第二个屏幕上选择Delimiters标题下的逗号。第三个屏幕允许您选择列数据格式（常规，文本，日期）

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

Answer 3

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

流程/代码步骤：

代码放在Worksheet_Change事件的“Sheet2”模块中，检查B列中的值是否被修改（如果需要，可以扩展到单个单元格“B1”），如果它会调用FilterAddress Sub，然后发送Target.Value。
根据“Sheet2”中单元格B1中输入的值，在“Sheet1”中使用AutoFilter。
使用SpecialCells(xlCellTypeVisible)循环显示可见单元格，并使用Dictionary对象，仅保留唯一的“车辆”。
将词典中唯一的“车辆”存储到VehicleArr阵列。
按照字符串值（从最小到最大）对VehicleArr数组进行排序。
根据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

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

3 个答案: