CODEWITHSUNDEEP
excelcomboboxvba
blair b
blair b

Reputation: 13

Adding an autofill combobox in workbook

I'm currently running in an issue where I have code setup that calls for a combobox to appear across all the cells in my worksheet where data validation is present. This works great for one worksheet, but I would like for this to occur for the entire set of worksheets in my workbook. Here is the code I'm currently running, I'm wondering if there are any quick solutions to this issue I'm currently facing. Thanks!

'==========================
Private Sub Worksheet_BeforeDoubleClick _
  (ByVal Target As Range, _
    Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject

Dim ws As Worksheet
Set ws = Sheets("Test")

Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
  With cboTemp
  'clear and hide the combo box
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains
      'a data validation list
    Cancel = True
    Application.EnableEvents = False
    'get the data validation formula
    str = Target.Validation.Formula1
    str = Right(str, Len(str) - 1)
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 5
      .ListFillRange = str
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
    'open the drop down list automatically
    Me.TempCombo.DropDown
  End If

errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub
'=========================================
Private Sub TempCombo_LostFocus()
  With Me.TempCombo
    .Top = 10
    .Left = 10
    .Width = 0
    .ListFillRange = ""
    .LinkedCell = ""
    .Visible = False
    .Value = ""
  End With
End Sub
 '====================================

Private Sub TempCombo_KeyDown(ByVal _
     KeyCode As MSForms.ReturnInteger, _
     ByVal Shift As Integer)
  Select Case KeyCode
    Case 9 'Tab
      ActiveCell.Offset(0, 1).Activate
    Case 13 'Enter
      ActiveCell.Offset(1, 0).Activate
    Case Else
        'do nothing
  End Select
End Sub
'====================================

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    Set Target = Range("A8")
    If Target = "" Then Exit Sub
    On Error GoTo Badname
    ActiveSheet.Name = Left(Target, 31)
    Exit Sub
Badname:
    MsgBox "Please revise the entry in A8." & Chr(13) _
    & "It appears to contain one or more " & Chr(13) _
    & "illegal characters." & Chr(13)
    Range("A8").Activate
End Sub

Upvotes: 1

Views: 634

Answers (1)

Maddy
Maddy

Reputation: 781

If you want run this code across all sheets then use Workbook_SheetBeforeDoubleClick event instead of Worksheet_BeforeDoubleClick.

Assumption: OLEObjects("TempCombo") name is same across all sheets.

    Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim str As String
    Dim cboTemp As OLEObject

    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet
        Set cboTemp = ws.OLEObjects("TempCombo")
          On Error Resume Next
          With cboTemp
          'clear and hide the combo box
            .ListFillRange = ""
            .LinkedCell = ""
            .Visible = False
          End With
        On Error GoTo errHandler
          If Target.Validation.Type = 3 Then
            'if the cell contains
              'a data validation list
            Cancel = True
            Application.EnableEvents = False
            'get the data validation formula
            str = Target.Validation.Formula1
            str = Right(str, Len(str) - 1)
            With cboTemp
              'show the combobox with the list
              .Visible = True
              .Left = Target.Left
              .Top = Target.Top
              .Width = Target.Width + 5
              .Height = Target.Height + 5
              .ListFillRange = str
              .LinkedCell = Target.Address
            End With
            cboTemp.Activate
            'open the drop down list automatically
            Me.TempCombo.DropDown
          End If

errHandler:
      Application.EnableEvents = True
      Exit Sub
    End Sub

Upvotes: 1

Related Questions