Apply text to a cell userform to worksheet in current working code

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
5,199
Office Version
  1. 2007
Platform
  1. Windows
Good morning,

The code in use is supplied below.
Currently when i press my Postage Sheet Transfer Button the values are added to my worksheet and the cell in column G is applied the interior RGB colour Red.

Please can you advise how i also have text in the same cell, so not only is it then shown as RED but also the word IN POST applied.

Have a nice day.

Code:
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 = ""
    .Cells(Lastrow + 1, 7).Interior.Color = RGB(255, 0, 0)
    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
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
@Logit
Did you see the huge drop down list I mentioned and supplied screen shot of.
 
Upvote 0
.
Add this to the bottom of the Userform_Initialize macro :

Code:
Dim l As MSForms.ComboBox
Dim i As Long: i = 0
Set l = Me.NameForDateEntryBox


While i < l.ListCount
 If "" = l.List(i, 0) Then: l.RemoveItem (i): Else i = 1 + i
Wend


The entire Userform_Initialize macro will look like this :

Code:
Private Sub UserForm_Initialize()
  Dim cl As Range, rng As Range, lstrw As Long, LastRow As Long, Lastrowa As Long, cntr As Integer
  
  TextBox2.SetFocus
  Application.ScreenUpdating = False
  LastRow = Sheets("POSTAGE").Cells(Rows.Count, "B").End(xlUp).Row
  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
  Sheets("POSTAGE").Cells(1, 12).Resize(Lastrowa).Clear
  
  cntr = 1
  With Sheets("POSTAGE")
    lstrw = .Range("B65536").End(xlUp).Row
    Set rng = .Range("B8:B" & lstrw)
    For Each cl In rng
      'If cl.Offset(0, 5).Value = "" Then Sheets("POSTAGE").Range("L" & cntr).Value = cl.Value: cntr = cntr + 1




      If cl.Offset(0, 5).Value = "POSTED" Then Sheets("POSTAGE").Range("L" & cntr).Value = cl.Value: cntr = cntr + 1 '<--- added this line




    Next


    If cntr = 1 Then
      MsgBox "ALL PARCELS HAVE NOW BEEN DELIVERED ", vbExclamation, "POSTAGE SHEET DATE TRANSFER MESSAGE"
      Unload PostageTransferSheet
    ElseIf cntr = 2 Then
      NameForDateEntryBox.AddItem .Range("L1").Value
    Else
   
      .Range("L1:L" & cntr - 1).Sort key1:=.Range("L1"), order1:=xlAscending, Header:=xlNo
      NameForDateEntryBox.List = .Range("L1:L" & cntr - 1).Value
      NameForDateEntryBox.List = Sheets("POSTAGE").Cells(1, 12).Resize(Lastrowa).Value
      


      '.Range("L1:L" & cntr - 1).Clear '<----- commented out this line




      TextBox2.SetFocus
    End If
  End With

[B][COLOR=#008000]'' NEW CODE ADDED IN RED ...[/COLOR][/B]
[B][COLOR=#ff0000]
Dim l As MSForms.ComboBox[/COLOR][/B]
[B][COLOR=#ff0000]Dim i As Long: i = 0[/COLOR][/B]
[B][COLOR=#ff0000]Set l = Me.NameForDateEntryBox[/COLOR][/B]
[B][COLOR=#ff0000]
[/COLOR][/B]
[B][COLOR=#ff0000]While i < l.ListCount[/COLOR][/B]
[B][COLOR=#ff0000] If "" = l.List(i, 0) Then: l.RemoveItem (i): Else i = 1 + i[/COLOR][/B]
[B][COLOR=#ff0000]Wend[/COLOR][/B]


  
  Application.ScreenUpdating = True
  TextBox1.Value = Format(CDbl(Date), "dd/mm/yyyy")
  TextBox7.Value = Format(CDbl(Date), "dd/mm/yyyy")
 
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,535
Messages
6,114,194
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top