Страницы: 1
RSS
Уникальные значения в Combobox из таблицы на другом листе. VBA
 
Здравствуйте. Помогите получить уникальные значения в Combobox в  User form из второго столбца таблицы, которая находится на другом листе. Если возможно, в алфавитном порядке.
 
Цитата
Hashtag написал:
Если возможно, в алфавитном порядке.
Сначала отсортируйте, потом тяните.
 
Цитата
V: Сначала отсортируйте, потом тяните
Hashtag, в таком случае и коллекции со словарями не нужны
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Здравствуйте, вариант.
Вредить легко, помогать трудно.
 
Вариант SQL запросом
 
nbaengineer, спасибо за ваш вариант. Возможно ли сделать, чтобы привязка была к самой таблице , а не к диапазону?

artemkau88, ваш вариант работает. Единственный вопрос, как указать таблицу, с которой приходят данные, на случай если их будет несколько на листе, просто с SQL не знаком совсем.
 
Вариант с привязкой к имени таблицы. Менять имя в коде ( зеленый комментарий)
В этом месте:
Код
Set strRange = ThisWorkbook.Sheets(2).ListObjects.Item("Таблица5")

SELECT DISTINCT - выборка уникальных значений

Немного подправил (с примерами).

Изменено: artemkau88 - 26.08.2021 17:22:52
 
artemkau88, спасибо за пример и пояснение. Единственная проблема, код выдает ошибку на пустую ячейку, если в соседней ячейке ввести значение. Возможно это поправить?
Изменено: Hashtag - 26.08.2021 18:01:15
 
Так?
Изменено: artemkau88 - 26.08.2021 18:13:13
 
Запустите форму в примере
 
artemkau88, да, то что нужно, спасибо вам большое за труды. И еще вопрос. В чем преимущество SQL запроса перед вариантом кода без SQL?
 
Подумалось мне, что так проще реализовать ответ на ваш вопрос.  :)  
Изменено: artemkau88 - 26.08.2021 18:26:18
 
Цитата
Hashtag написал:
Возможно ли сделать, чтобы привязка была к самой таблице , а не к диапазону?

Возможно
Изменено: nbaengineer - 27.08.2021 08:40:46
Вредить легко, помогать трудно.
 
Код
Sub Example()
    Dim r As Range, ar, ar1, ar2
    Set r = Worksheets("Лист2").ListObjects("Таблица1").ListColumns(1).DataBodyRange
    ar = r.Value
    ar1 = UniqueSortArr(ar)
    ar2 = NoDups(r)
End Sub

'Создание сортированного списка уникальных дат (VBA)
'=========================================================
' Author: nerv            | E-mail: nerv-net@yandex.ru
' Last Update: 14/09/2011 | Яндекс.Деньги: 41001156540584
'=========================================================
Private Function UniqueSortArr(ByRef v As Variant)
    Dim a
    Dim x, i&: If IsObject(v) Then v = v.Value
    On Error Resume Next
    With New Collection
        For Each x In v
            If VarType(x) = vbString Then x = Trim(x)
            If Len(x) > 0 Then
                a = CStr(x)
                If .Item(CStr(x)) = "" Then
                    For i = 1 To .Count
                        If x < .Item(i) Then
                            .Add x, CStr(x), Before:=i: Exit For
                        End If
                    Next
                    .Add x, CStr(x)
                End If
            End If
        Next
        ReDim v(1 To .Count)
        For i = 1 To .Count: v(i) = .Item(i): Next
        UniqueSortArr = v
    End With
End Function

' Извлечение уникальных
' ZVI
Function NoDups(Rng As Range)
  Dim Arr(), i&, s$, x
  Arr = Intersect(Rng.Parent.UsedRange, Rng).Value
  On Error Resume Next
  With New Collection
    For Each x In Arr()
      s = Trim(x)
      If Len(s) > 0 Then
        If IsEmpty(.Item(s)) Then
         For i = 1 To .Count
            If s < .Item(i) Then Exit For
          Next
          If i > .Count Then .Add s, s Else .Add s, s, Before:=i
        End If
      End If
    Next
    ReDim Arr(1 To .Count)
    For i = 1 To .Count
      Arr(i) = .Item(i)
    Next
  End With
  NoDups = Arr()
End Function
 
nbaengineer спасибо за доработанный вариант, все работает, единственное строчку
Код
Uniq.Add Arr(i, 1), CStr(Arr(i, 1))

заменил на:
Код
If Arr(i, 1) <> "" Then Uniq.Add Arr(i, 1), CStr(Arr(i, 1))

чтобы игнорировать пустые ячейки.
RAN спасибо, ваш вариант работает безупречно.
 
Цитата
Hashtag написал:
RAN спасибо, ваш вариант работает безупречно.
Это не мой. Авторы указаны. Мой только загашник.
Страницы: 1
Наверх