Cleaning up repetitive VBA code

[StuLux]

I have some lengthy VBA code that populates a searchable drop-down list of values and the code has to be repeated because I want it to work on 7 different columns. I have achieved this by repeating the code 7 times but this makes it quite unwieldy to maintain and tweak as all changes have to be made to the seven different sections of code. I can't help feeling that there may be a smarter way to define the variables and combine the seven routines in to one. I have reproduced the code below (this is only for two drop-down lists but should give you some idea of what I mean i.e. all of the sub routines are repeated with a different set of variables). What I would like to achieve is just one set of sub routines that are used in each instance of the drop down lists but obviously the correct list needs to be populated dependent on which column the user is in. Hope this makes sense.

'MEETING 1

'sheet name where the list (for combobox) is
Private Const sList1 As String = "Admin"
'cell where the list starts
Private Const sCell1 As String = "E1"
'column where the list is (the column of sCell above)
Private Const sCol1 As String = "E"
'range where the combobox applies
Private Const xCell1 As String = "W2:W1000"
'offset from xCell where the cursor goes (after completing the combobox) 1 means 1 column to the right of xCell
Private Const ofs1 As Long = 1

'MEETING 2
'sheet name where the list (for combobox) is
Private Const sList2 As String = "Admin"
'cell where the list starts
Private Const sCell2 As String = "I1"
'column where the list is (the column of sCell2 above)
Private Const sCol2 As String = "I"
'range where the combobox applies
Private Const xCell2 As String = "X2:X1000"
'offset from xCell where the cursor goes (after completing the combobox) 1 means 1 column to the right of xCell
Private Const ofs2 As Long = 1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' if selection is in a certain range (xCell) then Call toShowCombobox
    If Not Intersect(Range(xCell1), Target) Is Nothing And Target.Count = 1 Then
        Call toShowCombobox1
        Else
    If Not Intersect(Range(xCell2), Target) Is Nothing And Target.Count = 1 Then
        Call toShowCombobox2
        Else
        ComboBox1.Visible = False
        ComboBox2.Visible = False
    End If
    End If
End Sub


'MEETING 1
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

Private Sub ComboBox1_Change()

Dim d As Object, vList1, i As Long
vList1 = Sheets(sList1).Range(sCell1, Sheets(sList1).Cells(Rows.Count, sCol1).End(xlUp)).Value
 
With ComboBox1
    If .Value <> "" And IsError(Application.Match(.Value, vList1, 0)) Then
       
        Set d = CreateObject("scripting.dictionary")
        For i = LBound(vList1) To UBound(vList1)
       
        'Use this line below if you want search pattern as: *word*word
            If LCase(vList1(i, 1)) Like "*" & Replace(LCase(.Value), " ", "*") & "*" Then
              d(vList1(i, 1)) = 1
            End If
        Next
           .List = d.keys
           .DropDown
   
    ElseIf .Value = "" Then
            Call showALL1
    End If

End With
End Sub

Private Sub showALL1()
Dim vList, d As Object, i As Long
    If ComboBox1.Value = vbNullString Then
    vList = Sheets(sList1).Range(sCell1, Sheets(sList1).Cells(Rows.Count, sCol1).End(xlUp)).Value
        Set d = CreateObject("scripting.dictionary")
        For i = LBound(vList) To UBound(vList)
              d(vList(i, 1)) = ""
        Next
           ComboBox1.List = d.keys
    End If
End Sub

Private Sub ComboBox1_DropButtonClick()
    Call showALL1
End Sub

Private Sub ComboBox1_GotFocus()
    With ComboBox1
        .MatchEntry = fmMatchEntryNone
        .Value = ""
    End With
End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
        Select Case KeyCode
        Case 13 'Enter
           'Enter Key to fill the cell with combobox value
            If IsError(Application.Match(ComboBox1.Value, Sheets(sList1).Columns(sCol1), 0)) Then
                If Len(ComboBox1.Value) = 0 Then
                    ActiveCell = ""
                    Else
                    MsgBox "Wrong input", vbCritical
                End If
            Else
                ActiveCell = ComboBox1.Value
                ActiveCell.Offset(, ofs1).Activate
            End If
        Case 27, 9 'esc 'tab
                ComboBox1.Clear
                ActiveCell.Offset(, ofs1).Activate
        Case Else
            'do nothing
    End Select
End Sub

Sub toShowCombobox1()

Dim Target As Range

Set Target = ActiveCell
' if selection is in a certain range (xCell) then show combobox
If Not Intersect(Range(xCell1), Target) Is Nothing And Target.Count = 1 Then
       
'setting up combobox property
        With ComboBox1
        .Height = Target.Height + 5
        .Width = Target.Width + 10
        .Top = Target.Top - 2
        .Left = Target.Offset(0, 1).Left
        .Visible = True
        .Value = ""
        .Activate
        End With
  Else
    ComboBox1.Visible = False
  End If

End Sub

Private Sub ComboBox1_LostFocus()
'    If selection is still in this sheet
   
    If Selection.Worksheet.Name = Me.Name Then
        Call toShowCombobox1
    End If
End Sub

'MEETING 2
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

Private Sub ComboBox2_Change()

Dim d2 As Object, vList2, i As Long
vList2 = Sheets(sList2).Range(sCell2, Sheets(sList2).Cells(Rows.Count, sCol2).End(xlUp)).Value
 
With ComboBox2
    If .Value <> "" And IsError(Application.Match(.Value, vList2, 0)) Then
       
        Set d2 = CreateObject("scripting.dictionary")
        For i = LBound(vList2) To UBound(vList2)
       
        'Use this line below if you want search pattern as: word*word
'            If LCase(vList2(i, 1)) Like Replace(LCase(.Value), " ", "*") & "*" Then
       
        'Use this line below if you want search pattern as: *word*word
          If LCase(vList2(i, 1)) Like "*" & Replace(LCase(.Value), " ", "*") & "*" Then
   
              d2(vList2(i, 1)) = 1
            End If
        Next
           .List = d2.keys
           .DropDown
   
    ElseIf .Value = "" Then
            Call showALL2
           
    End If

End With

End Sub

Private Sub showALL2()
Dim vList2, d2 As Object, i As Long

    If ComboBox2.Value = vbNullString Then
        vList2 = Sheets(sList2).Range(sCell2, Sheets(sList2).Cells(Rows.Count, sCol2).End(xlUp)).Value
            Set d2 = CreateObject("scripting.dictionary")
            For i = LBound(vList2) To UBound(vList2)
                d2(vList2(i, 1)) = ""
            Next
       ComboBox2.List = d2.keys
    End If

End Sub

Private Sub ComboBox2_DropButtonClick()
    Call showALL2
End Sub

Private Sub ComboBox2_GotFocus()
    With ComboBox2
        .MatchEntry = fmMatchEntryNone
        .Value = ""
    End With
End Sub

Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Select Case KeyCode
    Case 13 'Enter
     
       'Enter Key to fill the cell with combobox value
        If IsError(Application.Match(ComboBox2.Value, Sheets(sList2).Columns(sCol2), 0)) Then
            If Len(ComboBox2.Value) = 0 Then
                ActiveCell = ""
                Else
                MsgBox "Wrong input", vbCritical
            End If
        Else
            ActiveCell = ComboBox2.Value
            ActiveCell.Offset(, ofs2).Activate
        End If
    Case 27, 9 'esc 'tab
            ComboBox2.Clear
            ActiveCell.Offset(, ofs2).Activate
    Case Else
        'do nothing
End Select

End Sub

Sub toShowCombobox2()

Dim Target2 As Range

Set Target2 = ActiveCell
' if selection is in a certain range (xCell) then show combobox
If Not Intersect(Range(xCell2), Target2) Is Nothing And Target2.Count = 1 Then
       
'setting up combobox property
        With ComboBox2
        .Height = Target2.Height + 5
        .Width = Target2.Width + 10
        .Top = Target2.Top - 2
        .Left = Target2.Offset(0, 1).Left
        .Visible = True
        .Value = ""
        .Activate
        End With
  Else
    ComboBox2.Visible = False
  End If

End Sub

Private Sub ComboBox2_LostFocus()
'    If selection is still in this sheet
   
    If Selection.Worksheet.Name = Me.Name Then
        Call toShowCombobox2
    End If
End Sub

*Also posted to the Microsoft Community Forum

 

[COwen]

You could try a for next loop.
For i = 1 to 7 or something like that.

 

[Norie]

Perhaps you could start by using something like this for showing the comboboxes.

Sub toShowCombobox(Target As Range, cb As Object)
       
    'setting up combobox property
    With cb
        .Height = Target.Height + 5
        .Width = Target.Width + 10
        .Top = Target.Top - 2
        .Left = Target.Offset(0, 1).Left
        .Visible = True
        .Value = ""
        .Activate
    End With
  
End Sub

To use this change the code in the SelectionChange event to this.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    ' if selection is in a certain range (xCell) then Call toShowCombobox
    If Not Intersect(Range(xCell1), Target) Is Nothing And Target.Count = 1 Then
        Call toShowCombobox(Target, Me.ComboBox1)
    Else
        If Not Intersect(Range(xCell2), Target) Is Nothing And Target.Count = 1 Then
            Call toShowCombobox(Target, Me.ComboBox2)
        Else
            ComboBox1.Visible = False
            ComboBox2.Visible = False
        End If
    End If
    
End Sub

 

[COwen]

I assume that the seven columns are on one sheet? If so Sheet1.Cells(1, i)

 

[StuLux]

Thank you both for your replies - I am continuing to look at this and will get back to you if I need more help