如何剪断一根绳子的一部分？

Question

我正在尝试从我拥有的字符串中删除重复项。

字符串如下所示：

word-1\word-2\word-3\word-3\word-3\word-3

我希望它看起来像这样：（没有重复）。

word-1\word-2\word-3

到目前为止，我想将字符串放入一个数组并通过 \ 拆分为项目。 我真的不知道我应该如何减少重复。 而且，我不知道会有多少重复。

这是我目前得到的：

Sub Split_and_remove()
  ' split items on \
  Dim item As String, newItem As String
  Dim items As Variant, newItems As Variant
  item = Sheet1.Range("A1").Value2
  items = Split(item, "\")
  newItems = items(0) + "\" + items(1) + "\" + items(2)
  Sheet1.Range("A4").Value2 = newItems
End Sub

谢谢！

Answer 1

这是一个带有集合的实现，所以你不需要像字典这样的外部对象：

Public Function GetUniqueValues(ByVal valueString As String, ByVal delimiter As String) As String
    With New Collection
        On Error Resume Next

        Dim item As Variant
        For Each item In Split(valueString, delimiter)
            .Add item, item

            If Err.Number = 0 Then _
                GetUniqueValues = GetUniqueValues & item & delimiter

            Err.Clear
        Next item
    End With

    GetUniqueValues = Left(GetUniqueValues, Len(GetUniqueValues) - Len(delimiter))
End Function

它可以与 VBA 的所有变体一起使用，而不仅仅是 Excel。

Answer 2

更多通往罗马的道路：

FilterXML()：

Sub tst()

Dim str1 As String, str2 As String

str1 = "word-1\word-2\word-3\word-3\word-3\word-3"
With Application
    str2 = Join(.Transpose(.FilterXML("<t><s>" & Replace(str1, "\", "</s><s>") & "</s></t>", "//s[not(preceding::*=.)]")), "\")
End With

End Sub

这需要 Excel2013 及更高版本。

---

字典：

更传统的是，我也会使用字典：

Sub tst()

Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim arr As Variant, x As Long
Dim str1 As String, str2 As String

str1 = "word-1\word-2\word-3\word-3\word-3\word-3"
arr = Split(str1, "\")

For x = LBound(arr) To UBound(arr)
    dict(arr(x)) = 1
Next
str2 = Join(dict.Keys, "\")

End Sub

Answer 3

请尝试下一个功能：

Function elimDuplicates(x As String) As String
  Dim sh As Worksheet, arr
  
  Set sh = ActiveSheet
  arr = Split(x, "\")
  With sh.cells(1, ActiveSheet.UsedRange.Columns.count).Resize(UBound(arr) + 1, 1)
    .Value = Application.Transpose(arr)
    .RemoveDuplicates Columns:=1, Header:=xlNo
    arr = sh.Range(.cells(1, 1), sh.cells(sh.cells(rows.count, _
                    .Column).End(xlUp).row, .Column)).Value
    .Clear
  End With
  elimDuplicates = Join(Application.Transpose(Application.Index(arr, 0, 1)), "\")
End Function

可以这样测试：

Sub testElimDupl()
  MsgBox elimDuplicates("word-1\word-2\word-3\word-3\word-3\word-3")
End Sub

Answer 4

使用字典。

Sub Split_and_remove()

  Dim item As String, newItem As String
  Dim items As Variant, newItems As Variant
  
  item = Sheet1.Range("A1").Value2

  Sheet1.Range("A4").Value2 = getArray(item)
End Sub
Function getArray(s As String)
    Dim Dic As Object ' Dictionary
    Dim a As Variant, vArray As Variant

    Set Dic = CreateObject("Scripting.Dictionary")
    vArray = Split(s, "\")
    For Each a In vArray
        If Dic.Exists(a) Then
        Else
            Dic.Add a, a
        End If
    Next a
    getArray = Join(Dic.Keys, "\")
End Function