none
Create Combobox in each row using VBA for number of records retrieved from database RRS feed

  • Question

  • Hi,

    Please could you let me know how do i create combo box for each record retrieved from a database and also add list to the combox box from a cell range?

    Private Sub cmdRefresh_Click()
    
    Application.ScreenUpdating = False
    
    On Error GoTo ErrorHandler
    
        Dim strTopCell As String 'first cell in the resultset
        Dim strLastColumn As String 'last column in the resultset
        Dim iRow     As Integer ' row number
        Dim rRange   As Range   ' range to be manipulated
        Dim iCount As Integer 'used for incrementing the progress bar while the query executes
        Dim row As Integer
        Dim lIndex As Integer
        Dim iRecNumber As Integer
        Dim iRowCount As Integer ' number of rows returned by the recordset
        Dim iRowLast As Integer
        
        strTopCell = "A4"
        strCollectionCategoryColumn = "H"
        strLastColumn = "J"
        iRow = Right(strTopCell, 1)
    
    'Snag the user-input parameters
        sStartDate = Cells(1, 2).Value
        'sEndDate = Cells(2, 2).Value
    
    ' Remove all previously-returned data from the worksheet
        iRowLast = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row 'last row w/data
           
        If iRowLast < iRow Then
            Rows(iRow & ":" & iRow).Select
        Else
            Rows(iRow & ":" & iRowLast).Select
        End If
        
        Selection.Delete Shift:=xlUp
        
        ActiveSheet.Protect Contents:=False
        x = ActiveSheet.UsedRange.Rows.Count 'reset the last cell reference; note that to do this, the data ROWS must be deleted.
        'using StartDate & EndDate values
            sSQL = "EXEC P_SELECT_MatterCollectionInfo " & vbCrLf
            sSQL = sSQL & "@AsofDate = '" & sStartDate & "'"  '& "', " & vbCrLf
            'sSQL = sSQL & "@EndDate = '" & sEndDate & "' " & vbCrLf
        
    Application.StatusBar = "Querying database.  This may take a few moments..."
    Load frmStatus
    frmStatus.Show modeless
    
        'connect to the database
            If Initialize("ignore") = False Then
                End
            End If
    
        Set recordset1 = CreateObject("ADODB.Recordset")
        recordset1.Open sSQL, cnn, adOpenForwardOnly, adLockReadOnly, adAsyncExecute
        
        DoEvents
            'update the progress bar here in a loop that checks to see if the recordset has completed opening
                iCount = 0
                DoEvents
                While recordset1.State <> 1
                    If iCount > 100 Then '- Round(100 / IIf((iMonths - 5) <= 0, iMonths, (iMonths - 5))) Then
                        iCount = 0
                    Else
                        iCount = iCount + 3 'Round(100 / IIf((iMonths - 5) <= 0, iMonths, (iMonths - 5)))
                    End If
                    DoEvents
                    frmStatus.frameProgressBar.Caption = Format((IIf(iCount < 0, 0, IIf(iCount > 100, 100, iCount)) / 100), "0%")
                    frmStatus.lblProgress.Width = 210 * (IIf(iCount < 0, 0, IIf(iCount > 100, 100, iCount)) / 100) ' The initial width of the progress bar is 210.  'PctDone * (.frameProgressBar.Width - 10)
                    Sleep 350 'number of milliseconds to wait
                Wend
        Range(strTopCell).CopyFromRecordset recordset1
        iRowCount = recordset1.RecordCount
    
    ' NOT WORKING
    '    For i = 4 To iRowCount + 4
    '        Set curCombo = ActiveSheet.Shapes.AddFormControl(xlDropDown, '        'Set curCombo = ActiveSheet.Shapes.AddFormControl(xlDropDown, '        With curCombo
    '            .ControlFormat.DropDownLines = 2
    '            .ControlFormat.AddItem "Item 1", 1
    '            .ControlFormat.AddItem "item 2", 2
    '            .Name = "cboCategory" & i
    '            .OnAction = "cboCategory" & i & "_Change"
    '        End With
    '        i = i + 1
    '    Next
    
    Dim rng As Excel.Range, cmb As OLEObject
    For Each rng In Sheet1.Range("H4:H12").Cells
    ' NOT WORKING
    '********************************************************************************************'
        With rng
            ' Failing in the below line
            Set cmb = .Parent.OLEObjects.Add("Forms.combobox.1")
            cmb.Top = .Top
            cmb.Left = .Left
            cmb.Width = .Width
            cmb.Height = .Height
            cmb.Name = "ComboBoxIn" & rng.Address(False, False)
            cmb.Object.List = Array("Ignored", "Correct", "Fixed")
         End With
    Next rng
    ' NOT WORKING
    '********************************************************************************************'
    
    frmStatus.lblStatus.Caption = "Copying Data..."
    Application.StatusBar = "Preparing data..."
    frmStatus.lblStatus.Caption = "Preparing data..."
        
    QuitMe:
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    
        Range("B1").Select ' select the StartDate cell
        
        frmStatus.Hide
        Unload frmStatus
        Application.StatusBar = False
        
        If recordset1.State = adStateOpen Then recordset1.Close
        
        Exit Sub
            
            
    ErrorHandler:
        MsgBox Err.Number & vbNewLine & Err.Description
        Resume QuitMe
            
    End Sub
    
    

    THanks

    Senthil



    Tuesday, August 7, 2018 3:56 PM

Answers

  • Thanks Terry, 

    I have used the following code;


        ' Only show the combo box where it is required, i mean the column
        If Left(Replace(Target.Address, "$", ""), 1) <> "K" Or Right(Target.Address, Len(Target.Address) - InStrRev(Target.Address, "$")) <= 3 Then '  Check if Category Column if not dont show the combboox
            ActiveSheet.Shapes.Item("Combo1").Visible = msoFalse
            Exit Sub
        End If
        
        ' Add a combo box
        Set combo1 = ActiveSheet.Shapes.Item("Combo1")
        If combo1 Is Nothing Then
            Set combo1 = ActiveSheet.Shapes.AddFormControl(xlDropDown, Target.Left, Target.Top, Target.Width, Target.Height)
        End If

    Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    
    On Error GoTo Errhandler
    If boolLoadRecord Then Exit Sub
    
    If Target.Count = 1 Then
        
        ' Only show the combo box where it is required, i mean the column
        If Left(Replace(Target.Address, "$", ""), 1) <> "K" Or Right(Target.Address, Len(Target.Address) - InStrRev(Target.Address, "$")) <= 3 Then '  Check if Category Column if not dont show the combboox
            ActiveSheet.Shapes.Item("Combo1").Visible = msoFalse
            Exit Sub
        End If
        
        ' Add a combo box
        Set combo1 = ActiveSheet.Shapes.Item("Combo1")
        If combo1 Is Nothing Then
            Set combo1 = ActiveSheet.Shapes.AddFormControl(xlDropDown, Target.Left, Target.Top, Target.Width, Target.Height)
        End If
        
        Dim lColIndex As Long
        Dim lRowIndex As Long
        Dim boolCatPresent As Boolean
        
        lColIndex = 14 ' N Column where cateegory List are stored.
        
        lRowIndex = Cells(Rows.Count, 14).End(xlUp).row ' get the last row of the category list
        
        ' Check if the value in the target cell is present in the category list if not add to the list
        If Not Target = "" Then
          For i = 4 To lRowIndex
            If Cells(i, 14).Value = Target.Value Then
                boolCatPresent = True
            End If
            Next
            If boolCatPresent = False Then Cells(lRowIndex + 1, lColIndex).Value = Target.Value
        End If
        ' Check if the value in the target cell is present in the category list if not add to the list
        
        lRowIndex = Cells(Rows.Count, 14).End(xlUp).row
      
        With combo1.OLEFormat.Object
                .ListFillRange = "$N$4:$N$" & lRowIndex
                .Display3DShading = False
                .OnAction = "ThisWorkbook.SetValue"
        End With
        
        combo1.Top = Target.Top
        combo1.Left = Target.Left
        combo1.Width = Target.Width
        combo1.Height = Target.Height - 3
        
        'refresh the combo and set the listindex
        For i = 0 To combo1.OLEFormat.Object.ListCount - 1
            If combo1.OLEFormat.Object.List(i + 1) = Trim(Target.Value) Then
                combo1.OLEFormat.Object.ListIndex = i + 1
                Exit For
            Else
                combo1.OLEFormat.Object.ListIndex = 0
            End If
        Next
        combo1.Visible = msoTrue
    


    Monday, September 10, 2018 7:01 AM

All replies

  • Hello Senthil,

    It seems that what you want is to set data validation for a cell.

    Please try to refer to below code and adjust it for your need.

    Sub TestMacro()
    'example for setting data validation for A1:A10
    For i = 1 To 10
    'get data item and combine them as a list string
    ListString = "data1,data2,data3"
    'set the list string to the cell data validation
    Cells(i, 1).Validation.Add xlValidateList, , , ListString
    Next i
    End Sub

    Best Regards,

    Terry


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Wednesday, August 8, 2018 1:33 AM
  • Thanks Terry, 

    I have used the following code;


        ' Only show the combo box where it is required, i mean the column
        If Left(Replace(Target.Address, "$", ""), 1) <> "K" Or Right(Target.Address, Len(Target.Address) - InStrRev(Target.Address, "$")) <= 3 Then '  Check if Category Column if not dont show the combboox
            ActiveSheet.Shapes.Item("Combo1").Visible = msoFalse
            Exit Sub
        End If
        
        ' Add a combo box
        Set combo1 = ActiveSheet.Shapes.Item("Combo1")
        If combo1 Is Nothing Then
            Set combo1 = ActiveSheet.Shapes.AddFormControl(xlDropDown, Target.Left, Target.Top, Target.Width, Target.Height)
        End If

    Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    
    On Error GoTo Errhandler
    If boolLoadRecord Then Exit Sub
    
    If Target.Count = 1 Then
        
        ' Only show the combo box where it is required, i mean the column
        If Left(Replace(Target.Address, "$", ""), 1) <> "K" Or Right(Target.Address, Len(Target.Address) - InStrRev(Target.Address, "$")) <= 3 Then '  Check if Category Column if not dont show the combboox
            ActiveSheet.Shapes.Item("Combo1").Visible = msoFalse
            Exit Sub
        End If
        
        ' Add a combo box
        Set combo1 = ActiveSheet.Shapes.Item("Combo1")
        If combo1 Is Nothing Then
            Set combo1 = ActiveSheet.Shapes.AddFormControl(xlDropDown, Target.Left, Target.Top, Target.Width, Target.Height)
        End If
        
        Dim lColIndex As Long
        Dim lRowIndex As Long
        Dim boolCatPresent As Boolean
        
        lColIndex = 14 ' N Column where cateegory List are stored.
        
        lRowIndex = Cells(Rows.Count, 14).End(xlUp).row ' get the last row of the category list
        
        ' Check if the value in the target cell is present in the category list if not add to the list
        If Not Target = "" Then
          For i = 4 To lRowIndex
            If Cells(i, 14).Value = Target.Value Then
                boolCatPresent = True
            End If
            Next
            If boolCatPresent = False Then Cells(lRowIndex + 1, lColIndex).Value = Target.Value
        End If
        ' Check if the value in the target cell is present in the category list if not add to the list
        
        lRowIndex = Cells(Rows.Count, 14).End(xlUp).row
      
        With combo1.OLEFormat.Object
                .ListFillRange = "$N$4:$N$" & lRowIndex
                .Display3DShading = False
                .OnAction = "ThisWorkbook.SetValue"
        End With
        
        combo1.Top = Target.Top
        combo1.Left = Target.Left
        combo1.Width = Target.Width
        combo1.Height = Target.Height - 3
        
        'refresh the combo and set the listindex
        For i = 0 To combo1.OLEFormat.Object.ListCount - 1
            If combo1.OLEFormat.Object.List(i + 1) = Trim(Target.Value) Then
                combo1.OLEFormat.Object.ListIndex = i + 1
                Exit For
            Else
                combo1.OLEFormat.Object.ListIndex = 0
            End If
        Next
        combo1.Visible = msoTrue
    


    Monday, September 10, 2018 7:01 AM