Блог

Главная - Вопросы по программированию - Удалите дубликаты и создайте уникальный список

Удалите дубликаты и создайте уникальный список

#excel #vba

#excel #vba

Вопрос:

Список фруктов содержит яблоко, банан, апельсин, а список цветов содержит красный, черный, оранжевый

итак, когда я многократно выбираю фрукты, а также цвета из выпадающего списка из ячейки «G1». Затем «Смещение (0, -1)» означает «F1», что показывает мне объединенный выходной список как — (Яблоко, банан, апельсин, красный, черный, оранжевый). Итак, список в ячейке «F1» содержит повторяющееся значение оранжевого цвета и печатается 2 раза. Он должен выбирать только уникальные элементы из выбранного и удалять дублирующийся и должен печатать в ячейке F1 как — (Яблоко, банан, апельсин, красный, черный).

 Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim rngDV As Range, oldVal As String, newVal As String
 Dim arr As Variant, El As Variant

 If Target.count > 1 Then GoTo exitHandler
 If Target.value = "" Then
   Application.EnableEvents = False
     Target.Offset(0, -1).value = ""
   Application.EnableEvents = True
   Exit Sub
 End If
 
 On Error Resume Next
 Set rngDV = cells.SpecialCells(xlCellTypeAllValidation)
 On Error GoTo exitHandler

 If rngDV Is Nothing Then GoTo exitHandler

 If Not Intersect(Target, rngDV) Is Nothing Then
   Application.EnableEvents = False
   newVal = Target.value: Application.Undo
   oldVal = Target.value: Target.value = newVal
  
   If Target.Column = 7 Then
    If oldVal <> "" Then
      If newVal <> "" Then
         arr = Split(oldVal, ",")
         For Each El In arr
            If El = newVal Then
                Target.value = oldVal
                GoTo exitHandler
            End If
         Next
         Target.value = oldVal amp; "," amp; newVal
         Target.EntireColumn.AutoFit
      End If
    End If
   End If
   writeSeparatedStringLast Target
End If

exitHandler:
  Application.EnableEvents = True
End Sub

Sub writeSeparatedStringLast(rng As Range)
  Dim arr As Variant, arrFin As Variant, El As Variant, k As Long, listBox As MSForms.listBox
  Dim arrFr As Variant, arrVeg As Variant, arrAnim As Variant, El1 As Variant
  Dim strFin As String ', rng2 as range
  
   arrFr = Split("Apple,Banana,Orange", ",")
   arrVeg = Split("Onion,Tomato,Cucumber", ",")
   arrAnim = Split("Red,Black,Orange", ",")
  arr = Split(rng.value, ",")

  For Each El In arr
    Select Case El
        Case "Fruits"
            arrFin = arrFr
        Case "Vegetables"
            arrFin = arrVeg
        Case "Colors"
            arrFin = arrAnim
    End Select
    For Each El1 In arrFin
        strFin = strFin amp; El1 amp; ", "
    Next
  Next
  strFin = left(strFin, Len(strFin) - 1)
  With rng.Offset(0, -1)
    .value = strFin
    .WrapText = True
    .Select
  End With
End Sub

'Firstly run the next Sub, in order to create a list validation in range "G1":
Sub CreateValidationBis()
 Dim sh As Worksheet, rng As Range
 Set sh = ActiveSheet
 Set rng = sh.Range("G1")
 
 With rng.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                   Operator:=xlBetween, Formula1:="Fruits,Vegetables,Colors"
    .IgnoreBlank = True
    .InCellDropdown = True
    .ShowInput = True
    .ShowError = True
 End With
End Sub

Комментарии:

1. Он не содержит повторяющихся значений, он содержит уникальные значения для обоих списков, у вас есть фрукт и цвет с одинаковым названием, название уникально для обоих списков, таким образом, когда вы объединяете их, у вас получается «Оранжевый», уникальный как для фруктов, так и для цвета. Если бы у вас был фрукт «Персик» и цвет «Персик», вы бы получили тот же результат.

2. Да, вы тоже правы

3. Но это всего лишь пример, который я привел здесь, что если я выбрал фрукты и цвет из выпадающего списка, то в ячейке F1 я буду указан как — Яблоко, банан, апельсин, красный, черный, оранжевый . Итак, оранжевый цвет будет напечатан два раза в ячейке, просто пример . Я хочу избежать этого и хочу, чтобы уникальное значение отображалось оранжевым один раз в списке.

4. Я могу придумать два возможных способа выполнить то, что вы хотите: сначала объединить все массивы, а затем удалить дубликаты. Во-вторых, после объединения списков добавьте код для удаления дубликатов в F1.

5. Во-первых; Все массивы объединены «strFin = left(strFin, Len(strFin) — 1)», но я не могу поместить код для удаления дубликатов и не имею кода для удаления дубликатов для таких массивов, как в моем коде. Не могли бы вы мне помочь, пожалуйста

Ответ №1:

Подойдет ли этот код для удаления дубликатов из выходных массивов и присвоения мне уникального значения.

 Public Function RemoveDuplicateWords(InputString As String) As String
    Dim InputArray() As String
    InputArray = Split(InputString, " ")

    Dim DictUnique As Object
    Set DictUnique = CreateObject("Scripting.Dictionary")

    Dim OutputString As String

    Dim Word As Variant
    For Each Word In InputArray
        If Not DictUnique.Exists(Word) Then
            DictUnique.Add Word, 1
            OutputString = OutputString amp; " " amp; Word
        End If
    Next Word

    RemoveDuplicateWords = Trim$(OutputString)
End Function