Results 1 to 10 of 10

Thread: Carregar Lista na Caixa de Combinação - ActiveX

  1. #1
    Neophyte cvns's Avatar
    Join Date
    Aug 2019
    Posts
    4
    Articles
    0
    Excel Version
    2007

    Smile Carregar Lista na Caixa de Combinação - ActiveX



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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!
    Attached Files Attached Files
    Last edited by cvns; 2019-08-30 at 04:34 AM.

  2. #2
    Administrator AliGW's Avatar
    Join Date
    Nov 2015
    Location
    Ipswich, Suffolk, England
    Posts
    1,270
    Articles
    0
    Excel Version
    Office 365 Subscription
    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.
    Ali
    Enthusiastic self-taught user of MS Excel!

  3. #3
    Super Moderator Bob Phillips's Avatar
    Join Date
    Mar 2011
    Posts
    1,668
    Articles
    0
    Excel Version
    O365
    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 by Bob Phillips; 2019-08-30 at 11:51 AM.

  4. #4
    Super Moderator Bob Phillips's Avatar
    Join Date
    Mar 2011
    Posts
    1,668
    Articles
    0
    Excel Version
    O365
    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

  5. #5
    Super Moderator Bob Phillips's Avatar
    Join Date
    Mar 2011
    Posts
    1,668
    Articles
    0
    Excel Version
    O365
    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

  6. #6
    Super Moderator Bob Phillips's Avatar
    Join Date
    Mar 2011
    Posts
    1,668
    Articles
    0
    Excel Version
    O365
    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 by Bob Phillips; 2019-08-30 at 12:13 PM.

  7. #7
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,606
    Articles
    0
    Excel Version
    365
    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).
    Attached Files Attached Files

  8. #8
    Neophyte cvns's Avatar
    Join Date
    Aug 2019
    Posts
    4
    Articles
    0
    Excel Version
    2007

    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.
    Attached Files Attached Files

  9. #9
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,606
    Articles
    0
    Excel Version
    365
    See attached, for clarity, I've left the zzz sheet visible; you should hide it.
    Attached Files Attached Files

  10. #10
    Neophyte cvns's Avatar
    Join Date
    Aug 2019
    Posts
    4
    Articles
    0
    Excel Version
    2007
    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!!!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •