从列中拆分单词并根据数组中的条件重新加入

Question

我的传播sheet 中有一个“D”列，其中包含要安装的软件列表。列表很长，我只想安装几个应用程序。这里有几个例子：

第2行：许可证-E3；米尼塔布 17；米尼塔布 18； Proficy Historian 7.0； ;

第 3 行：许可证-E3；适用于 UNIX 和 OpenVMS 14.0 的 Attachmate 反射；感知内容桌面客户端；

第4行：许可证-E1； Avaya one-X® 通讯器； PipelineBillingInterfaceSystemClient-V2_0; ; SAP-GUI-3应用程序； Minitab 18

因此，在第一个示例中，我希望 D 列第 2 行只说： 许可证-E3，Minitab 18

第 3 行说：License-E3,Reflection

还有 4 说：License-E1,Minitab 18

根据用户 ID 列自动筛选行，即此 sheet 中的列 A。

评论区基本就是我想做的

到目前为止，这是我的代码：

Sub FilterSoftware()

  Dim cl As Range, rng As Range, Lastrow As Integer, sSoft() As String, i As Long
  Dim vSoft As Variant, sNew As String, j As Long, sNewSoft() As String
    
  vSoft = Array("License-E3", "License-E1", "Reflection", "Minitab 18", "RSIGuard", "Java")
  
      
  Dim Ws As Worksheet: Set Ws = Sheet1
  
  With Ws
    Lastrow = .Range("D" & .Rows.Count).End(xlUp).Row
  End With

  Set rng = Range("D2:D" & Lastrow)

  For Each cl In rng.SpecialCells(xlCellTypeVisible)
      sSoft = Split(cl, ";")
        For i = LBound(sSoft) To UBound(sSoft)
          If Not sSoft(i) = " " Then
            For j = LBound(vSoft) To UBound(vSoft)
              sNewSoft = Split(vSoft(j), " ")
              Debug.Print Trim$(sSoft(i))
              Debug.Print Trim$(vSoft(j))

              'if sSoft(i) contains any words from vSoft(j)
              'Join vSoft(j) with comma delimiter until full
              'and overwrite in column D

            Next j
          End If
        Next i
   Next cl
End Sub

Answer 1

请使用下一个改编代码。它将 return 在下一列中，仅用于测试原因。如果 return 是您需要的，您可以将 cl.Offset(0, 1).Value = Join(sNew, ",") 更改为 cl.Value = Join(sNew, ","):

Sub FilterSoftware()
  Dim cl As Range, rng As Range, Lastrow As Long, sSoft
  Dim vSoft, sNew, i As Long, j As Long, t As Long
    
  vSoft = Array("License-E3", "License-E1", "Reflection", "Minitab 18", "RSIGuard", "Java")
  
  Dim Ws As Worksheet: Set Ws = ActiveSheet ' Sheet1
  Lastrow = Ws.Range("D" & Ws.rows.count).End(xlUp).row

  Set rng = Range("D2:D" & Lastrow)
  ReDim sNew(UBound(vSoft)) 'redim the array to a dimension to be sure it will include all occurrences
  
  For Each cl In rng.SpecialCells(xlCellTypeVisible)
      sSoft = Split(cl, ";")
        For i = LBound(sSoft) To UBound(sSoft)
          If Not sSoft(i) = "" Then                 'for cases of two consecutive ";"
            For j = LBound(vSoft) To UBound(vSoft)
                If InStr(1, sSoft(i), vSoft(j), vbTextCompare) > 0 Then
                    sNew(t) = vSoft(j): t = t + 1: Exit For
                End If
            Next j
          End If
        Next i
        If t > 0 Then
            ReDim Preserve sNew(t - 1)              'keep only the array filled elements
            cl.Offset(0, 1).Value = Join(sNew, ",") 'put the value in the next column (for testing reason)
            ReDim sNew(UBound(vSoft)): t = 0        'reinitialize the variables
        End If
   Next cl
End Sub

从列中拆分单词并根据数组中的条件重新加入

Split words from column and re-join based on criteria from an array

excel

vba

excel-2016