VBA Excel Dynamic Data filter with Dynamically created ComboBox

Yes, so redundant. It’s a dynamically created comboBox (or DropDown) OLE Object that can be modified in runtime (for example, to set a filter). It’s not fully working as expected, but kind of. As it was not behaving well, I ripped it off from my code, but consider it interestingly enough to kept it for future needings. I have achieved this functionallity via Validation method, which is not so tricky and behaves well in nearly all Excel versions out there. Inspiration came from here, here and here.

Private oShpComboBox As Excel.Shape
'Private oComboBox As Excel.Shape 'Private WithEvents oComboBox As MSForms.comboBox
Private oOLE As Excel.OLEObject
Private bEvents As Boolean
Private oCodeMod As VBIDE.CodeModule

Private Sub Worksheet_Activate()
    Call sComboBox_Delete
    Call sCombobox_Create
End Sub

Private Sub Worksheet_Deactivate()
    Call sComboBox_Delete
End Sub

Private Sub sCombobox_Create()
    Dim strCode As String
    Dim lgLine As Long

    With Me.Cells(1, 1)
        ' oShpComboBox can not handle WithEvents
        'Set oShpComboBox = Me.Shapes.AddFormControl(xlDropDown, _
                                                    Left:=.Left, _
                                                    Top:=.Top, _
                                                    Width:=.Width, _
                                                    Height:=.Height)

        Set oOLE = Me.OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
                                     Link:=False, _
                                     DisplayAsIcon:=False, _
                                     Left:=.Left, _
                                     Top:=.Top, _
                                     Width:=.Width, _
                                     Height:=.Height)
    End With
    With oOLE
        .Name = "cboFilter"
        .Visible = False
    End With
    'MsgBox TypeName(oOLE)

    Set oCodeMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule

    With oCodeMod
        lgLine = .CreateEventProc("Change", oOLE.Name) + 1
        strCode = vbNullString
        strCode = strCode & "    Dim rgName As Excel.Range" & vbNewLine _
                          & "    Dim oCell As Excel.Range" & vbNewLine _
                          & "" & vbNewLine _
                          & "    With " & oOLE.Name & ".Object" & vbNewLine _
                          & "        .BorderStyle = 0 'fmBorderStyleNone" & vbNewLine _
                          & "" & vbNewLine _
                          & "        .Font.Name = ""Calibri""" & vbNewLine _
                          & "        .Font.Size = 10" & vbNewLine _
                          & "        .Value = vbNullString" & vbNewLine _
                          & "        .List = Array() '""Item1"", ""Item2"", ""Item3"", ""Item4"")" & vbNewLine _
                          & "        Set rgName = ActiveSheet.Names(strDataBase).RefersToRange" & vbNewLine _
                          & "        For Each oCell In rgName.SpecialCells(xlCellTypeConstants).Cells" & vbNewLine _
                          & "            If oCell.Value2 Like ""*"" & " & oOLE.Name & ".value & ""*"" Then" & vbNewLine _
                          & "                .AddItem oCell.Value2" & vbNewLine _
                          & "            End If" & vbNewLine _
                          & "        Next oCell" & vbNewLine _
                          & "        '.AddItem " & """Item1""" & vbNewLine _
                          & "    End With" & vbNewLine _
                          & "" & vbNewLine _
                          & "    'MsgBox ""Name: "" & " & oOLE.Name & ".Value" & vbNewLine _
                          & "    ActiveCell.Value2 = " & oOLE.Name & ".value"
        .InsertLines lgLine, strCode

        'lgLine = .CreateEventProc("LostFocus", oOLE.Name) + 1
        'strCode = vbNullString
        'strCode = strCode & "    " & oOLE.Name & ".Visible = False"
        '.InsertLines lgLine, strCode
    End With

    Set oCodeMod = Nothing
End Sub

Private Sub DeleteProcedureCode(ByVal ProcedureName As String)
    Dim ProcStartLine As Long
    Dim ProcLineCount As Long

    On Error Resume Next

    'Creating object of workbook module
    Set oCodeMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule

    'Checking whether the procedure exist in the codemodule
    If Not oCodeMod Is Nothing Then
        ProcStartLine = 0

        With oCodeMod
            'Function assigning the line no. of starting line for the procedure
            ProcStartLine = .ProcStartLine(ProcedureName, vbext_pk_Proc)

            If ProcStartLine > 0 Then
                'Function assign the no. of lines in the procedure
                ProcLineCount = .ProcCountLines(ProcedureName, vbext_pk_Proc)

                'Delete all the lines in the procedure
                .DeleteLines ProcStartLine, ProcLineCount
            End If
        End With
    End If

    On Error GoTo 0
End Sub

Private Sub sComboBox_Delete()
    On Error Resume Next
    Set oCodeMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule
    Me.Shapes("cboFilter").Delete
    Call DeleteProcedureCode("cboFilter_GetFocus")
    Call DeleteProcedureCode("cboFilter_LostFocus")
    Call DeleteProcedureCode("cboFilter_Change")
    On Error GoTo 0
End Sub

This can be activated via code like the one following. Just paste it inside Worksheet_SelectionChange procedure to get it fired when activecell falls in either Columns 5 or 6:

    If Not (Intersect(Target, Me.Columns(5)) Is Nothing) Then
        If Target.Rows.Count = 1 Then
            strDataBase = ***** customize DataBase name

'bEvents = Application.EnableEvents
'Application.EnableEvents = False
'Target.value = vbNullString
'Application.EnableEvents = bEvents

            Set oOLE = Me.OLEObjects("cboFilter")
            With oOLE
                .Visible = True
                .Left = Target.Left
                .Top = Target.Top
                .Width = Target.Width
                .Height = Target.Height

                '.Border.Weight = xlHairline
                '.Border.LineStyle = xlContinuous 'xlLineStyleNone
                With .Object
                    .BorderStyle = 0 'fmBorderStyleNone

                    .Font.Name = "Calibri"
                    .Font.Size = 10
                End With
            End With
'
'            Call cboFilter_Change
        End If

    ElseIf Not (Intersect(Target, Me.Columns(6)) Is Nothing) Then
        If Target.Rows.Count = 1 Then
            strDataBase = ***** customize DataBase name

'bEvents = Application.EnableEvents
'Application.EnableEvents = False
'Target.value = vbNullString
'Application.EnableEvents = bEvents

            Set oOLE = Me.OLEObjects("cboFilter")
            With oOLE
                .Visible = True
                .Left = Target.Left
                .Top = Target.Top
                .Width = Target.Width
                .Height = Target.Height

                '.Border.Weight = xlHairline
                '.Border.LineStyle = xlContinuous 'xlLineStyleNone
                With .Object
                    .BorderStyle = 0 'fmBorderStyleNone

                    .Font.Name = "Calibri"
                    .Font.Size = 10
                End With
            End With
'
'            Call cboFilter_Change
        End If
    Else
'        Set oOLE = Me.OLEObjects("cboFilter")
'        oOLE.Visible = False
    End If
[/sourcecode]