VBA：仅向 excel 组合框添加唯一值，该组合框通过在工作簿打开时循环访问源工作表范围来填充答案

【问题标题】：VBA: Only add unique values to excel combobox, which is populated by looping through a source sheet range on workbook openVBA：仅向 excel 组合框添加唯一值，该组合框通过在工作簿打开时循环访问源工作表范围来填充
【发布时间】：2021-04-11 19:16:08
【问题描述】：

下面的代码基本上是在打开工作簿时查看源工作表，从范围中获取值并循环通过将每个值添加到组合框。

我想要做的是包含一些代码以确保只添加唯一值，即不添加重复值。

有什么想法可以让它发挥作用吗？

谢谢！

Private Sub Workbook_Open()

   Dim wb As Workbook
Set wb = ThisWorkbook

Dim Home As Worksheet
Dim Datasource As Worksheet


'Define Variables and dropdown object
Dim LastRow As Long
Dim MIDCell As Range


Dim ComboMID As ComboBox


Set Home = ActiveSheet
Set Home = Worksheets("UPDATER")
Set Datasource = wb.Sheets("LaunchCodes")


'asign dropdown object to combobox
Set ComboMID = Home.OLEObjects("ComboBox1").Object


'Empty the combobox currnetly to avoid duplicating content
ComboMID.Clear



'With and For loop to put all values in games launch code column, ignoring any blanks,  into combobox
With Datasource
      LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
    For Each MIDCell In .Range("D2:D1000" & LastRow)
         If MIDCell.Value <> "" Then
            ComboMID.AddItem MIDCell.Value
           
    End If
    
Next
End With



End Sub

【问题讨论】：

标签： excel vba combobox

【解决方案1】：

组合框独有

了解组合框研究this。

您可以将Set ComboMID = Home.OLEObjects("ComboBox1").Object行之后的代码替换为以下sn-p：

Dim rng As Range
With DataSource
    LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
    Set rng = .Range("D2:D" & lastrow)
End With
Dim Unique As Variant
Unique = getUniqueFromRange(rng)
If Not IsEmpty(Unique) Then
    ComboMID.List = Unique
End If

它使用以下函数：

Function getUniqueFromRange( _
    rng As Range) _
As Variant
    
    If rng Is Nothing Then
        Exit Function
    End If
    
    Dim Data As Variant
    If rng.Cells.CountLarge > 1 Then
        Data = rng.Value
    Else
        ReDim Data(1 To 1, 1 To 1)
        Data(1, 1) = rng.Value
    End If
    cCount = UBound(Data, 2)
    
    Dim cValue As Variant
    Dim i As Long
    Dim j As Long
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For i = 1 To UBound(Data, 1)
            For j = 1 To cCount
                cValue = Data(i, j)
                If Not IsError(cValue) And Not IsEmpty(cValue) Then
                    .Item(cValue) = Empty
                End If
            Next j
        Next i
        If .Count > 0 Then
            getUniqueFromRange = .Keys
        End If
    End With
    
End Function

【讨论】：

【解决方案2】：

下面的代码避免了循环遍历工作表中的单元格，因为它很慢。实际上，可以通过将列表读入变量来加快该过程（事实上，我的代码也是如此），但使用 Excel 自己的 RemoveDuplicates 方法似乎更有效。

Private Sub Workbook_Open()
    ' 155

    Dim Wb          As Workbook
    Dim ComboMid    As ComboBox
    Dim TmpClm      As Long                 ' number of temporary column
    Dim Arr         As Variant              ' unique values from column D
    
    Set Wb = ThisWorkbook
    With Wb.Worksheets("UPDATER")
        Set ComboMid = .OLEObjects("ComboBox1").Object
        With .UsedRange
            TmpClm = .Column + .Columns.Count
        End With
    End With
    
    With Wb.Sheets("LaunchCodes")
        ' create a copy of your data (without header) in an unused column
        .Cells(2, "D").CurrentRegion.Copy .Cells(1, TmpClm)
        .Cells(1, TmpClm).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
        Arr = .Cells(1, TmpClm).CurrentRegion.Value
        .Columns(TmpClm).ClearContents
    End With
    
    With ComboMid
        .List = Arr
        .ListIndex = 0                      ' assign first list item to Value
    End With
End Sub

您无需清除上述代码中的组合框，因为用新数组替换 List 属性会自动删除之前的所有内容。

【讨论】：