我需要根据工作表上的列填充组合框

Question

我在用户窗体上有一个组合框，该组合框当前由表中的列填充。 Column A 此列有一个工具编号，其中两个数字可以完全相同，除了末尾的字母。 （例如单元格 A5 和 A6）如何填充组合框以使其仅包含该数字的最新版本？

Answer 1

通过扭曲填充独特的组合框

• 调整第一个单元格地址、工作表和组合框。

Option Explicit

Sub PopulateComboUnique()
    
    Const First As String = "A2"
    
    Dim rg As Range: Set rg = RefColumn(Sheet1.Range(First))
    If rg Is Nothing Then Exit Sub ' empty column range
    
    Dim sData As Variant: sData = GetColumnRange(rg)
    
    Dim dData As Variant: dData = ArrUniqueSpecial(sData)
    If IsEmpty(dData) Then Exit Sub ' no unique values
        
    Sheet1.ComboBox1.List = dData
    
'    Dim n As Long
'    For n = LBound(dData) To UBound(dData)
'        Debug.Print dData(n)
'    Next n
        
End Sub

Function RefColumn( _
    ByVal FirstCellRange As Range) _
As Range
    If FirstCellRange Is Nothing Then Exit Function
    With FirstCellRange.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With
End Function

Function GetColumnRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    Dim cData As Variant
    With rg.Columns(1)
        If .Rows.Count = 1 Then
            ReDim cData(1 To 1, 1 To 1): cData(1, 1) = .Value
        Else
            cData = .Value
        End If
    End With
    GetColumnRange = cData
End Function

Function ArrUniqueSpecial( _
    ByVal sData As Variant) _
As Variant
    If IsEmpty(sData) Then Exit Function
   
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 1 To UBound(sData, 1)
        Key = sData(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 1 Then ' not allowing zero or one character
                dict(Left(Key, Len(Key) - 1)) = Right(Key, 1)
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Function
    
    Dim dData() As String: ReDim dData(1 To dict.Count)
    
    r = 0
    For Each Key In dict.Keys
        r = r + 1
        dData(r) = Key & dict(Key)
    Next Key

    ArrUniqueSpecial = dData
End Function