Carregar Lista na Caixa de Combinação - ActiveX

cvns

New member
Joined
Aug 30, 2019
Messages
4
Reaction score
0
Points
0
Excel Version(s)
2007
Amigos, bom dia!

Poderiam me ajudar com um problema que estou tendo, pois gostaria de carregar uma lista no controle activex, através de código VBA, onde as informações da lista se encontra na coluna "B" a partir da linha 9, também informo que a mesma possui nomes em duplicidade, possui 100 linhas e está fora da ordem alfabética, sendo assim vocês poderiam me ajudar com esse problema? Ressalto que a lista é alimentada com novos itens e os mesmos devem ser atualizados assim que eu clicar na caixa de combinação - ActiveX.

Ficarei grato se vocês puderam me ajudar com esse problema!
 

Attachments

  • Exemplo.xlsm
    13.5 KB · Views: 8
Last edited:
Welcome to the forum. :)

The lingua franca here is English: please pose your question in English (you can use Google Translate to help you).

Thanks.
 
This should help you

Code:
Sub LoadCombobox()
Dim ary1 As Variant, ary2 As Variant
Dim low As Long, high As Long, nextitem As Long
Dim i As Long
    With ActiveSheet
    
        ary1 = Application.Transpose(.Range(.Range("B9"), .Range("B9").End(xlDown)))
        QSortInPlace ary1
        
        low = LBound(ary1)
        high = UBound(ary1)
        ReDim ary2(low To high)
        ary2(low) = ary1(low)
        nextitem = 2
        For i = low + 1 To high
        
            If ary1(i) <> ary1(i - 1) Then
            
                ary2(nextitem) = ary1(i)
                nextitem = nextitem + 1
            End If
        Next i
        ReDim Preserve ary2(low To nextitem - 1)
        .ComboBox1.List = ary2
    End With
End Sub

But not that it does use a hefty quick sort routine as well which I will post separately in 2 parts as it is too long.
 
Last edited:
Code:
Public Function QSortInPlace( _
    ByRef InputArray As Variant, _
    Optional ByVal LB As Long = -1&, _
    Optional ByVal UB As Long = -1&, _
    Optional ByVal Descending As Boolean = False, _
    Optional ByVal CompareMode As VbCompareMethod = vbTextCompare, _
    Optional ByVal NoAlerts As Boolean = False) As Boolean
Dim Temp As Variant
Dim Buffer As Variant
Dim CurLow As Long
Dim CurHigh As Long
Dim CurMidpoint As Long
Dim Ndx As Long
Dim pCompareMode As VbCompareMethod
Static RecursionLevel As Long
    QSortInPlace = False
    RecursionLevel = RecursionLevel + 1
    
    If RecursionLevel = 1 Then
        If IsArray(InputArray) = False Then
        
            If NoAlerts = False Then
                
                MsgBox "The InputArray parameter is not an array."
            End If
            
            RecursionLevel = RecursionLevel - 1
            Exit Function
        End If
    
        If LB < 0 Then LB = LBound(InputArray)
        If UB < 0 Then UB = UBound(InputArray)
        
        Select Case NumberOfArrayDimensions(InputArray)
        
            ' Zero dimensions indicates an unallocated
            Case 0
            
                If NoAlerts = False Then
                    
                    MsgBox "The InputArray is an empty, unallocated array."
                End If
                
                RecursionLevel = RecursionLevel - 1
                Exit Function
            
            ' We sort ONLY single dimensional arrays.
            Case 1
            
            ' We sort ONLY single dimensional arrays.
            Case Else
            
                If NoAlerts = False Then
                
                    MsgBox "The InputArray is multi-dimensional." & _
                          "QSortInPlace works only on single-dimensional arrays."
                End If
                
                RecursionLevel = RecursionLevel - 1
                Exit Function
        End Select
        
        If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then
        
            If NoAlerts = False Then
                
                MsgBox "InputArray is not an array of simple data types."
                RecursionLevel = RecursionLevel - 1
                Exit Function
            End If
        End If
        
        Select Case LB
            
            Case Is < LBound(InputArray)
                
                If NoAlerts = False Then
                    
                    MsgBox "The LB lower bound parameter is less than the LBound of the InputArray"
                End If
                
                RecursionLevel = RecursionLevel - 1
                Exit Function
                
            Case Is > UBound(InputArray)
                
                If NoAlerts = False Then
                    
                    MsgBox "The LB lower bound parameter is greater than the UBound of the InputArray"
                End If
                
                RecursionLevel = RecursionLevel - 1
                Exit Function
            
            Case Is > UB
                
                If NoAlerts = False Then
                    
                    MsgBox "The LB lower bound parameter is greater than the UB upper bound parameter."
                End If
                
                RecursionLevel = RecursionLevel - 1
                Exit Function
        End Select
    
        Select Case UB
            
            Case Is > UBound(InputArray)
                
                If NoAlerts = False Then
                    
                    MsgBox "The UB upper bound parameter is greater than the upper bound of the InputArray."
                End If
                
                RecursionLevel = RecursionLevel - 1
                Exit Function
            
            Case Is < LBound(InputArray)
                
                If NoAlerts = False Then
                    
                    MsgBox "The UB upper bound parameter is less than the lower bound of the InputArray."
                End If
                
                RecursionLevel = RecursionLevel - 1
                Exit Function
            
            Case Is < LB
                
                If NoAlerts = False Then
                    
                    MsgBox "the UB upper bound parameter is less than the LB lower bound parameter."
                End If
                
                RecursionLevel = RecursionLevel - 1
                Exit Function
        End Select
    
        
        If UB = LB Then
            
            QSortInPlace = True
            RecursionLevel = RecursionLevel - 1
            Exit Function
        End If
    
    End If ' RecursionLevel = 1
    If (CompareMode = vbBinaryCompare) Or (CompareMode = vbTextCompare) Then
        pCompareMode = CompareMode
    Else
        pCompareMode = vbTextCompare
    End If
    CurLow = LB
    CurHigh = UB
    CurMidpoint = ((LB + UB) \ 2) + IIf(LB - 0, 1, 0) ' note integer division (\) here
    Temp = InputArray(CurMidpoint)
    
    Do While (CurLow <= CurHigh)
        
        Do While QSortCompare(V1:=InputArray(CurLow), V2:=Temp, CompareMode:=pCompareMode) < 0
            
            CurLow = CurLow + 1
            If CurLow = UB Then
                
                Exit Do
            End If
        Loop
        
        Do While QSortCompare(V1:=Temp, V2:=InputArray(CurHigh), CompareMode:=pCompareMode) < 0
            
            CurHigh = CurHigh - 1
            If CurHigh = LB Then
               
               Exit Do
            End If
        Loop
    
        If (CurLow <= CurHigh) Then
            
            Buffer = InputArray(CurLow)
            InputArray(CurLow) = InputArray(CurHigh)
            InputArray(CurHigh) = Buffer
            CurLow = CurLow + 1
            CurHigh = CurHigh - 1
        End If
    Loop
    
    If LB < CurHigh Then
        
        QSortInPlace InputArray:=InputArray, LB:=LB, UB:=CurHigh, _
            Descending:=Descending, CompareMode:=pCompareMode, NoAlerts:=True
    End If
    
    If CurLow < UB Then
        
        QSortInPlace InputArray:=InputArray, LB:=CurLow, UB:=UB, _
            Descending:=Descending, CompareMode:=pCompareMode, NoAlerts:=True
    End If
    
    If Descending = True Then
        
        If RecursionLevel = 1 Then
            
            ReverseArrayInPlace2 InputArray, LB, UB
        End If
    End If
    
    RecursionLevel = RecursionLevel - 1
    QSortInPlace = True
End Function
 
Code:
Public Function QSortCompare( _
     V1 As Variant, _
     V2 As Variant, _
     Optional CompareMode As VbCompareMethod = vbTextCompare) As Long
 Dim D1 As Double
 Dim D2 As Double
 Dim S1 As String
 Dim S2 As String
 Dim Compare As VbCompareMethod
         If CompareMode = vbBinaryCompare Or CompareMode = vbTextCompare Then
             
             Compare = CompareMode
         Else
             
             Compare = vbTextCompare
         End If
         
         If IsArray(V1) = True Or IsArray(V2) = True Then
             
             Err.Raise 13
             Exit Function
         End If
     
         If IsObject(V1) = True Or IsObject(V2) = True Then
             
             Err.Raise 13
             Exit Function
         End If
     
         If IsSimpleNumericType(V1) = True Then
         
             If IsSimpleNumericType(V2) = True Then
                 
                 D1 = CDbl(V1)
                 D2 = CDbl(V2)
                 If D1 = D2 Then
                 
                     QSortCompare = 0
                     Exit Function
                 End If
                 If D1 < D2 Then
                     QSortCompare = -1
                     Exit Function
                 End If
                 If D1 > D2 Then
                     QSortCompare = 1
                     Exit Function
                 End If
             End If
     End If
     If IsNumeric(V1) = True And IsNumeric(V2) = True Then
        D1 = CDbl(V1)
         D2 = CDbl(V2)
         If D1 = D2 Then
             QSortCompare = 0
             Exit Function
         End If
         If D1 < D2 Then
             QSortCompare = -1
            Exit Function
         End If
         If D1 > D2 Then
             QSortCompare = 1
             Exit Function
         End If
     End If
     S1 = CStr(V1)
     S2 = CStr(V2)
     QSortCompare = StrComp(S1, S2, Compare)
 End Function
  
 Public Function NumberOfArrayDimensions(Arr As Variant) As Long
 Dim Ndx As Long
 Dim Res As Long
     On Error Resume Next
     Do
         Ndx = Ndx + 1
         Res = UBound(Arr, Ndx)
     Loop Until Err.Number <> 0
     
     NumberOfArrayDimensions = Ndx - 1
 End Function
  
 Public Function ReverseArrayInPlace(InputArray As Variant, _
     Optional NoAlerts As Boolean = False) As Boolean
 Dim Temp As Variant
 Dim Ndx As Long
 Dim Ndx2 As Long
 Dim OrigN As Long
 Dim NewN As Long
 Dim NewArr() As Variant
     ReverseArrayInPlace = False
     
     If IsArray(InputArray) = False Then
        If NoAlerts = False Then
             MsgBox "The InputArray parameter is not an array."
         End If
         Exit Function
     End If
     Select Case NumberOfArrayDimensions(InputArray)
         Case 0
            If NoAlerts = False Then
                 MsgBox "The input array is an empty, unallocated array."
             End If
             Exit Function
         Case 1
         Case Else
             If NoAlerts = False Then
                 MsgBox "The input array multi-dimensional. ReverseArrayInPlace works only " & _
                        "on single-dimensional arrays."
             End If
             Exit Function
     End Select
     If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then
         If NoAlerts = False Then
             MsgBox "The input array contains arrays, objects, or other complex data types." & vbCrLf & _
                 "ReverseArrayInPlace can reverse only arrays of simple data types."
             Exit Function
         End If
    End If
     
     ReDim NewArr(LBound(InputArray) To UBound(InputArray))
     NewN = UBound(NewArr)
     For OrigN = LBound(InputArray) To UBound(InputArray)
         NewArr(NewN) = InputArray(OrigN)
         NewN = NewN - 1
     Next OrigN
     
     For NewN = LBound(NewArr) To UBound(NewArr)
         InputArray(NewN) = NewArr(NewN)
     Next NewN
     
     ReverseArrayInPlace = True
 End Function

 Public Function ReverseArrayInPlace2(InputArray As Variant, _
     Optional LB As Long = -1, Optional UB As Long = -1, _
     Optional NoAlerts As Boolean = False) As Boolean
 Dim N As Long
 Dim Temp As Variant
 Dim Ndx As Long
 Dim Ndx2 As Long
 Dim OrigN As Long
 Dim NewN As Long
 Dim NewArr() As Variant
     ReverseArrayInPlace2 = False
     If IsArray(InputArray) = False Then
         If NoAlerts = False Then
             MsgBox "The InputArray parameter is not an array."
         End If
         Exit Function
     End If
     
     Select Case NumberOfArrayDimensions(InputArray)
         Case 0
             If NoAlerts = False Then
                 MsgBox "The input array is an empty, unallocated array."
             End If
             Exit Function
         Case 1
         Case Else
             If NoAlerts = False Then
                 MsgBox "The input array multi-dimensional. ReverseArrayInPlace works only " & _
                        "on single-dimensional arrays."
             End If
             Exit Function
     
     End Select
     If IsSimpleDataType(InputArray(LBound(InputArray))) = False Then
         If NoAlerts = False Then
             MsgBox "The input array contains arrays, objects, or other complex data types." & vbCrLf & _
                 "ReverseArrayInPlace can reverse only arrays of simple data types."
             Exit Function
         End If
     End If
     
     ReDim NewArr(LBound(InputArray) To UBound(InputArray))
     NewN = UBound(NewArr)
     If LB < 0 Then
         LB = LBound(InputArray)
     End If
     If UB < 0 Then
         UB = UBound(InputArray)
     End If
     
     For OrigN = LBound(InputArray) To UBound(InputArray)
         If OrigN < LB Then
             NewArr(OrigN) = InputArray(OrigN)
         ElseIf OrigN > UB Then
             NewArr(OrigN) = InputArray(OrigN)
         Else
             NewArr(NewN) = InputArray(OrigN)
         End If
         NewN = NewN - 1
     Next OrigN
     
     For NewN = LBound(NewArr) To UBound(NewArr)
         InputArray(NewN) = NewArr(NewN)
     Next NewN
     
     ReverseArrayInPlace2 = True
 End Function
 Public Function IsSimpleNumericType(V As Variant) As Boolean
 If IsSimpleDataType(V) = True Then
     Select Case VarType(V)
         Case vbBoolean, _
                 vbByte, _
                 vbCurrency, _
                 vbDate, _
                 vbDecimal, _
                 vbDouble, _
                 vbInteger, _
                 vbLong, _
                 vbSingle
             IsSimpleNumericType = True
         Case vbVariant
             If IsNumeric(V) = True Then
                 IsSimpleNumericType = True
             Else
                 IsSimpleNumericType = False
             End If
         Case Else
             IsSimpleNumericType = False
     End Select
 Else
     IsSimpleNumericType = False
 End If
 End Function
 Public Function IsSimpleDataType(V As Variant) As Boolean
     On Error Resume Next
     If IsArray(V) = True Then
         IsSimpleDataType = False
         Exit Function
     End If
     
     If IsObject(V) = True Then
         IsSimpleDataType = False
         Exit Function
     End If
     
     Select Case VarType(V)
         Case vbArray, vbDataObject, vbObject, vbUserDefinedType
             IsSimpleDataType = False
         Case Else
             IsSimpleDataType = True
     End Select
 End Function
 Public Function IsArrayAllocated(Arr As Variant) As Boolean
 Dim N As Long
     If IsArray(Arr) = False Then
         IsArrayAllocated = False
         Exit Function
     End If
     
     On Error Resume Next
     N = UBound(Arr, 1)
     If Err.Number = 0 Then
     
         IsArrayAllocated = True
     Else
     
         IsArrayAllocated = False
     End If
 End Function
 
Here is a simpler Quicksort that I have found in my archives, you can use this instead of the last 2 posts that have a much more versatile Quicksort

You need to replace these lines

Code:
        QSortInPlace ary1
        
        low = LBound(ary1)
        high = UBound(ary1)

with

Code:
        low = LBound(ary1)
        high = UBound(ary1)
        Qicksort1DArray ary1, low, high

Code:
Public Sub Quicksort1DArray(ByRef ary As Variant, aryLower As Long, aryUpper As Long)
Dim pivotVal As Variant
Dim swap As Variant
Dim tmpLower As Long
Dim tmpUpper As Long
 
    tmpLower = aryLower
    tmpUpper = aryUpper
    pivotVal = ary((aryLower + aryUpper) \ 2)
     
    Do While (tmpLower <= tmpUpper)
    
       Do While (ary(tmpLower) < pivotVal And tmpLower < aryUpper)
       
          tmpLower = tmpLower + 1
       Loop
      
       Do While (pivotVal < ary(tmpUpper) And tmpUpper > aryLower)
       
          tmpUpper = tmpUpper - 1
       Loop
     
       If (tmpLower <= tmpUpper) Then
       
          swap = ary(tmpLower)
          ary(tmpLower) = ary(tmpUpper)
          ary(tmpUpper) = swap
          tmpLower = tmpLower + 1
          tmpUpper = tmpUpper - 1
       End If
    Loop
     
    If (aryLower < tmpUpper) Then Quicksort1DArray ary, aryLower, tmpUpper
    If (tmpLower < aryUpper) Then Quicksort1DArray ary, tmpLower, aryUpper
End Sub
 
Last edited:
An alternative…
It uses a very hidden sheet to get unique values from your list of names, sort them and load the combobox.
Keep cell B8 unused (although we can work around this requirement).
 

Attachments

  • ExcelGuru10192Exemplo.xlsm
    24.4 KB · Views: 7
Carregar lista na caixa de combinação - ActiveX

Amigos, bom dia!

Fico agradecido pela ajuda aqui, prestado por todos vocês, tente adaptar em meu plano ou códigos que você me envia através deste fórum, mas não deu certo. Caso alguém ainda queira me ajudar vou postar a planilha verdadeiro onde eu estou fazendo os meus trabalhos.
 

Attachments

  • CVNS.xlsm
    187.7 KB · Views: 9
See attached, for clarity, I've left the zzz sheet visible; you should hide it.
 

Attachments

  • Chandoo10192CVNS.xlsm
    32 KB · Views: 10
Prezados, bom dia!

Comunico que foi resolvido meu problema, agradeço a todos por ajudar, principalmente o sr. p45cal que teve a paciência em desempenhar um ótimo suporte perante minha duvidas e questionamento leigos. Muito obrigado a todas!!!
 
Back
Top