Highlite drop down selection in existing working code

[ipbr21054]

Good morning,

I have a userform which has a drop down list complete with customers names.
I use this to then add a date to that customer.

This is an example of what i do,

I see that the customer has received his parcel so i select his name from the drop down list & then i press my transfer button.
Pressing the transfer button then adds a date in column G alongside the customer that i had just selected.

This is the code for the transfer button.

Private Sub DateTransferButton_Click()'Dantes code
    Dim sh As Worksheet
    Dim b As Range
    Dim wName As String, res As Variant
    
    If NameForDateEntryBox = -1 Then
        MsgBox "Please Select A Customer", vbCritical, "Delivery Parcel Date Transfer"
        Exit Sub
    End If
    
    If TextBox7.Value = "" Or Not IsDate(TextBox7.Value) Then
        MsgBox "Please Enter A Valid Date", vbCritical, "Delivery Parcel Date Transfer"
        TextBox7 = ""
        TextBox7.SetFocus
        Exit Sub
    End If
    
    wName = NameForDateEntryBox.List(NameForDateEntryBox.ListIndex)
    Set sh = Sheets("POSTAGE")
    Set b = sh.Columns("B").Find(wName, LookIn:=xlValues, lookat:=xlWhole)
    If Not b Is Nothing Then
        If sh.Cells(b.Row, "G").Value <> "" Then
            MsgBox "DATE HAS BEEN ENTERED ALREADY !" & vbCrLf & "Click OK To Go Check It Out ", vbCritical, "Delivery Parcel Date Transfer"
            TextBox7 = ""
            Unload PostageTransferSheet
            Cells(b.Row, "G").Select
        Else
            sh.Cells(b.Row, "G").Value = CDate(TextBox7.Value)
            MsgBox "Delivery Date Updated", vbInformation, "Delivery Parcel Date Transfer"
        End If
    End If
    NameForDateEntryBox = ""
    TextBox7 = ""
    TextBox7.Value = Format(CDbl(Date), "dd/mm/yyyy")
End Sub

Im looking to see how the drop down is populated ??

Private Sub TextBox2_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)    Dim fndRng As Range
    Dim findString As String
    Dim i As Integer
    Dim wsPostage As Worksheet
    
    findString = Me.TextBox2.Value
    If Len(findString) = 0 Then Exit Sub
    
    Set wsPostage = ThisWorkbook.Worksheets("POSTAGE")
    i = 1
    Do
        Set fndRng = Nothing
        Set fndRng = wsPostage.Range("B:B").Find(What:=findString & Format(i, " 000"), _
                                                    LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, _
                                                    SearchDirection:=xlNext, MatchCase:=False)
        If Not fndRng Is Nothing Then
            i = i + 1
            Cancel = True
        End If
    Loop Until fndRng Is Nothing
    
    Me.TextBox2.Value = findString & Format(i, " 000")
    Cancel = False
    
End Sub

What i am looking to do is the have the selected customer in the drop down list either change color or have a coloured background.
Just as a visual helper so you know not to select it as its been selected & logged already

 

[ipbr21054]

Here is the drop down list in question.

Maybe something like If column G has a value of a date in it the change drop down name a different colour or highlite it.
If no date in column G then do nothing

 

[ipbr21054]

Any advice for this request please.

As a name is selected i wish to have that customers row background highlited or even have the text a different colur "just to show its been sorted".
So next time i open this drop down i will see various customers with highlited names or text colour changed etc so my users know not to select that one.
Some repeat customers are shown in the drop down like this.
TOM JONES 001
TOM JONES 002
TOM JONES 003

When the parcel arrives for TOM JONES 001 it is then selected & transfered to my date with todays date.
Next time you open the drop down list you should see TOM JONE 001 row background highlited & its text a different colour to advise its been sorted.
This will then leave TOM JONES 002 & TOM JONES 003 untouched & awaiting parcel to be delieverd so it then can have this applied to as & when.

Maybe something like the attached photo but with the name obviously showing over the white background.
Many thanks & have a nice day in this uk heat wave

 

[sykes]

I seem to remember seeing a similar post a few days ago, and one of the Top Neddies on here saying that this wasn't possible.
My only thoughts are, that it might be better to load the dropdown during the userform_initialize event, from Column B in your "Postage" sheet - but only load the names which don't already have an associated date in Column G.
That way, your users can't select a customer name, for which there's already an associated "Delivered" date.

 

[ipbr21054]

Hi,
Thats sound like it would work for me.
Would you mind advising the code so i could give it a trial run.

Have a nice day

 

[sykes]

First, you need to find out how the dropdown is populated. Is it programmatically, from a list on another sheet, or from a built-in list?
If it's programmatically, then can you post the code.
If it's a list, then is it a named range, or just a list on another sheet somewhere?

Please confirm the type of control your "DropDown" is, and what it's called. From the code you've posted, I'm guessing it's called "NameForDateEntryBox" but need to be sure, as you've not given us any details.

Also, please post any code you already have which is either:
a. Associated with the dropdown
b. Within the userform's _initialize event.

 

[ipbr21054]

OK,
Im not 100% sure so below is the info that you might require.
I have learning issues so maybe what you require is there but i need to try & understand what youre asking for.
So here goes.

Worksheet called POSTED,right click & view code.

Private Sub BottomOfPage_Click()    Application.Goto Sheets("POSTAGE").Range("A" & Rows.Count).End(xlUp), True
    ActiveWindow.SmallScroll UP:=10
End Sub
Private Sub ComboBox1_Change()
  Dim r As Range
  Set r = Range("B7", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible) _
    .Find(ComboBox1.Value)
  If Not r Is Nothing Then r.Select
  ComboBox1.ListIndex = -1
End Sub
Private Sub ComboBox1_DropButt*******()
  RangeUniqueSortFillControl Range("B7", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible), Sheet13.ComboBox1
End Sub
Private Sub CommandButton1_Click()
PostageTransferSheet.Show
End Sub
Private Sub SortCustomerAZ_Click()
    
    Dim x As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("POSTAGE")
        If .AutoFilterMode Then .AutoFilterMode = False
        x = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        .Range("A8:I" & x).Sort key1:=Range("A8"), order1:=xlAscending, Header:=xlGuess
        
    End With
                      
    ActiveWorkbook.Save
    
    Application.ScreenUpdating = True
    Sheets("POSTAGE").Range("A8").Select
    
End Sub
Private Sub TopOfPage_Click()
Range("A8").Select
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .Column = 1 Then Exit Sub
        If .Column = 7 Then Exit Sub
        If .Count = 1 And Not .HasFormula Then
            Application.EnableEvents = False
            .Value = UCase(.Value)
            Application.EnableEvents = True
        End If
    End With
End Sub
Private Sub DHL_Click()
ActiveWorkbook.FollowHyperlink Address:="http://www.dhl.co.uk/en/express/tracking.html", NewWindow:=True
End Sub
Private Sub LabelButton_Click()
TrackingLabel.Show
End Sub
Private Sub My_Hermes_Click()
ActiveWorkbook.FollowHyperlink Address:="https://www.myhermes.co.uk/tracking-results.html", NewWindow:=True
End Sub
Private Sub ROYALMAILButton_Click()
ActiveWorkbook.FollowHyperlink Address:="https://www.royalmail.com/track-your-item", NewWindow:=True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If Intersect(Target, Range("A8:I" & LastRow)) Is Nothing Then Exit Sub
    If Target.Column <> 4 Then
        Range("A8:C" & LastRow).Interior.ColorIndex = 6
        Range("E8:I" & LastRow).Interior.ColorIndex = 6
        Target.Interior.ColorIndex = 3
    End If
    Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Activate()
Application.Goto Sheets("POSTAGE").Range("A" & Rows.Count).End(xlUp).Offset(1, 0), True
ActiveWindow.SmallScroll UP:=16


PostageTransferSheet.Show
End Sub

Field where drop down is situated is called NameForDateEntryBox
Its code is,

Private Sub NameForDateEntryBox_Change()        If NameForDateEntryBox.Text = "" Then
            Exit Sub
        Else
            TextBox7.SetFocus
        End If
 
    End Sub

This is the whole code for the userform.

Private Sub CustomerSearchBox_Change()'Modified  10/3/2018  5:51:42 AM  EDT
Dim SearchString As String
Dim SearchRange As Range
SearchString = CustomerSearchBox.Value
Dim LastRow As Long
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Set SearchRange = Range("B8:B" & LastRow).Find(SearchString, LookIn:=xlValues, lookat:=xlWhole)
If SearchRange Is Nothing Then MsgBox SearchString & "  Not Found": Exit Sub
SearchRange.Select
Unload Me
End Sub


Private Sub DateTransferButton_Click()
'Dantes code
    Dim sh As Worksheet
    Dim b As Range
    Dim wName As String, res As Variant
    
    If NameForDateEntryBox = -1 Then
        MsgBox "Please Select A Customer", vbCritical, "Delivery Parcel Date Transfer"
        Exit Sub
    End If
    
    If TextBox7.Value = "" Or Not IsDate(TextBox7.Value) Then
        MsgBox "Please Enter A Valid Date", vbCritical, "Delivery Parcel Date Transfer"
        TextBox7 = ""
        TextBox7.SetFocus
        Exit Sub
    End If
    
    wName = NameForDateEntryBox.List(NameForDateEntryBox.ListIndex)
    Set sh = Sheets("POSTAGE")
    Set b = sh.Columns("B").Find(wName, LookIn:=xlValues, lookat:=xlWhole)
    If Not b Is Nothing Then
        If sh.Cells(b.Row, "G").Value <> "" Then
            MsgBox "DATE HAS BEEN ENTERED ALREADY !" & vbCrLf & "Click OK To Go Check It Out ", vbCritical, "Delivery Parcel Date Transfer"
            TextBox7 = ""
            Unload PostageTransferSheet
            Cells(b.Row, "G").Select
        Else
            sh.Cells(b.Row, "G").Value = CDate(TextBox7.Value)
            MsgBox "Delivery Date Updated", vbInformation, "Delivery Parcel Date Transfer"
        End If
    End If
    NameForDateEntryBox = ""
    TextBox7 = ""
    TextBox7.Value = Format(CDbl(Date), "dd/mm/yyyy")
End Sub
Private Sub DHLButton_Click()
ActiveWorkbook.FollowHyperlink Address:="http://www.dhl.co.uk/en/express/tracking.html", NewWindow:=True
End Sub
Private Sub HERMESButton_Click()
ActiveWorkbook.FollowHyperlink Address:="https://www.myhermes.co.uk/tracking-results.html", NewWindow:=True
End Sub
Private Sub LABELSbutton_Click()
TrackingLabel.Show
End Sub
Private Sub ROYALMAILButton_Click()
ActiveWorkbook.FollowHyperlink Address:="https://www.royalmail.com/track-your-item", NewWindow:=True
End Sub
Private Sub PostageSheetTransferButton_Click()
Cancel = 0
If TextBox2.Text = "" Then
    Cancel = 1
    MsgBox "Customer`s Name Not Entered", vbCritical, "POSTAGE TRANSFER SHEET"
    TextBox2.SetFocus
ElseIf TextBox3.Text = "" Then
    Cancel = 1
    MsgBox "Item Description Not Entered", vbCritical, "POSTAGE TRANSFER SHEET"
    TextBox3.SetFocus
ElseIf TextBox4.Text = "" Then
    Cancel = 1
    MsgBox "Tracking Number Not Entered", vbCritical, "POSTAGE TRANSFER SHEET"
    TextBox4.SetFocus
ElseIf ComboBox1.Text = "" Then
    Cancel = 1
    MsgBox "Username Not Entered", vbCritical, "POSTAGE TRANSFER SHEET"
    ComboBox1.SetFocus
    
ElseIf OptionButton1.Value = False And OptionButton2.Value = False And OptionButton3.Value = False Then
    Cancel = 1
    MsgBox "You Must Select An Ebay Account", vbCritical, "POSTAGE TRANSFER SHEET"
    
ElseIf OptionButton4.Value = False And OptionButton5.Value = False And OptionButton6.Value = False Then
    Cancel = 1
    MsgBox "You Must Select An Origin", vbCritical, "POSTAGE TRANSFER SHEET"
    
End If


If Cancel = 1 Then
        Exit Sub
End If


Dim i As Long
Dim x As Long
Dim ctrl As Control
Dim LastRow As Long
LastRow = ThisWorkbook.Worksheets("POSTAGE").Cells(Rows.Count, 1).End(xlUp).Row
    


    
 With ThisWorkbook.Worksheets("POSTAGE")
    .Cells(LastRow + 1, 1).Value = TextBox1.Text: TextBox1.Value = ""
    .Cells(LastRow + 1, 2).Value = TextBox2.Text: TextBox2.Value = ""
    .Cells(LastRow + 1, 3).Value = TextBox3.Text: TextBox3.Value = ""
    .Cells(LastRow + 1, 5).Value = TextBox4.Text: TextBox4.Value = ""
    .Cells(LastRow + 1, 9).Value = ComboBox1.Text: ComboBox1.Value = ""
    .Cells(LastRow + 1, 4).Value = TextBox6.Text: TextBox6.Value = ""
    If OptionButton1.Value = True Then .Cells(LastRow + 1, 8).Value = "DR": OptionButton1.Value = False
    If OptionButton2.Value = True Then .Cells(LastRow + 1, 8).Value = "IVY": OptionButton2.Value = False
    If OptionButton3.Value = True Then .Cells(LastRow + 1, 8).Value = "N/A": OptionButton3.Value = False
    If OptionButton4.Value = True Then .Cells(LastRow + 1, 6).Value = "EBAY": OptionButton4.Value = False
    If OptionButton5.Value = True Then .Cells(LastRow + 1, 6).Value = "WEB SITE": OptionButton5.Value = False
    If OptionButton6.Value = True Then .Cells(LastRow + 1, 6).Value = "N/A": OptionButton6.Value = False
    
        Dim colorHTML As String, r As String, g As String, b As String
        If MsgBox("HAS SECURITY MARK BEEN APPLIED ?", vbYesNo + vbExclamation, "PINK LIPSTICK MESSAGE") = vbYes Then
            colorHTML = "FF0099"
            r = WorksheetFunction.Hex2Dec(Left(colorHTML, 2))
            g = WorksheetFunction.Hex2Dec(Mid(colorHTML, 3, 2))
            b = WorksheetFunction.Hex2Dec(Right(colorHTML, 2))
            .Cells(LastRow + 1, 4).Interior.Color = RGB(r, g, b)
        End If
        MsgBox "Customer Postage Sheet Updated", vbInformation, "SUCCESSFUL MESSAGE"
    End With
    
TextBox1.Value = Format(CDbl(Date), "dd/mm/yyyy")
TextBox2.SetFocus
TextBox1.Value = Now
TextBox1.Value = Format(CDbl(Date), "dd/mm/yyyy")
End Sub
Private Sub UserForm_Initialize()
'Modified  10/3/2018  5:51:42 AM  EDT
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("POSTAGE").Cells(Rows.Count, "B").End(xlUp).Row
Dim Lastrowa As Long
Sheets("POSTAGE").Cells(8, 2).Resize(LastRow - 7).Copy Sheets("POSTAGE").Cells(1, 12)
Lastrowa = Sheets("POSTAGE").Cells(Rows.Count, "L").End(xlUp).Row
Sheets("POSTAGE").Cells(1, 12).Resize(Lastrowa).Sort key1:=Cells(1, 12).Resize(Lastrowa), order1:=xlAscending, Header:=xlNo
CustomerSearchBox.List = Sheets("POSTAGE").Cells(1, 12).Resize(Lastrowa).Value
NameForDateEntryBox.List = Sheets("POSTAGE").Cells(1, 12).Resize(Lastrowa).Value
Sheets("POSTAGE").Cells(1, 12).Resize(Lastrowa).Clear
Application.ScreenUpdating = True
'USERNAME COMBOBOX


TextBox1.Value = Format(CDbl(Date), "dd/mm/yyyy")
TextBox7.Value = Format(CDbl(Date), "dd/mm/yyyy")
TextBox2.SetFocus
End Sub
Private Sub TextBox1_Change()
    TextBox1 = UCase(TextBox1)
End Sub
Private Sub TextBox2_Change()
    TextBox2 = UCase(TextBox2)
End Sub
Private Sub TextBox3_Change()
    TextBox3 = UCase(TextBox3)
End Sub
Private Sub TextBox4_Change()
    TextBox4 = UCase(TextBox4)
End Sub
Private Sub ComboBox1_Change()
    ComboBox1 = UCase(ComboBox1)
End Sub
Private Sub TextBox6_Change()
    TextBox6 = UCase(TextBox6)
End Sub
Private Sub TextBox2_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    Dim fndRng As Range
    Dim findString As String
    Dim i As Integer
    Dim wsPostage As Worksheet
    
    findString = Me.TextBox2.Value
    If Len(findString) = 0 Then Exit Sub
    
    Set wsPostage = ThisWorkbook.Worksheets("POSTAGE")
    i = 1
    Do
        Set fndRng = Nothing
        Set fndRng = wsPostage.Range("B:B").Find(What:=findString & Format(i, " 000"), _
                                                    LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, _
                                                    SearchDirection:=xlNext, MatchCase:=False)
        If Not fndRng Is Nothing Then
            i = i + 1
            Cancel = True
        End If
    Loop Until fndRng Is Nothing
    
    Me.TextBox2.Value = findString & Format(i, " 000")
    Cancel = False
    
End Sub
Private Sub NameForDateEntryBox_Change()
        If NameForDateEntryBox.Text = "" Then
            Exit Sub
        Else
            TextBox7.SetFocus
        End If
 
    End Sub


Private Sub VerticalCloseForm_Click()
Unload PostageTransferSheet
End Sub

The worksheet POSTAGE has the customers names in column B & these names start at row 8 & continue down the page.
These are the names that are then in the drop down list which show up in the list sorted A-Z

Alt & F11 brings up the new window where on the left i see ThisWorkBook file.
Looking inside this file there is nothing that relates to the worksheet POSTAGE

 

[sykes]

OK.
Can you use Alt & F11 again - to bring up the VBA browser - like you did before.
On the left is "VBA Project" then the name of your Excel file.
In the "Forms" folder (double-click to open) you'll see your UserForm. I'm guessing it's called "PostageTransferSheet"
Double-click it (or right-click & select "ViewObject") this'll display your userform, before it's actually made visual for real use.
Find your dropdown, and right-click it; select "Properties."
The properties for your dropdown box, will probably open up on the left-hand-side, under the VBA project (depending upon how you have your VBA explorer set up.
Looking down the properties (in alphabetical order) is there anything in the "RowSource" entry? If so, what?

 

[ipbr21054]

Hi
I’m out but I remember that row source is empty.

 

[sykes]

Well something must be populating that dropdown, so it must be code.
I'm guessing it's the userform's _initialize event.
When you're home, go into your VBA explorer (Alt + F11) and right-click the userform (in one of its blank areas), selecting "View code." On the right-hand side of the window - at the top - , from the right-hand dropdown (left-hand one should now have the name of your userform) select "Initialize".
Is there any code there? Particular that which refers to the dropdown - which I think is called "NameForDateEntryBox."