DWRgt2885

New Member
Joined
Nov 20, 2017
Messages
23
Hey all,
Thought I'd give you folks a good laugh, perhaps even a hard cry by taking a look at the "Submit" button i have in my ever growing user form for an Order Follow up system. This is a multitude of other's work stitched and sewn together over the years. Everything is working, and it's not even slow, but i know there is a better way to do this. I'd like a good critiquing(roast) if you will. Thanks in advance, and don't be shy.

Code:
Private Sub cmbSubmit_Click()
Dim rowCount As Long
Dim ctl As Control
Dim iRow As Long
Dim WS As Worksheet
    Set WS = Worksheets("Order Status")
    strPwd = "2885"
     
     With ActiveSheet
    .Unprotect Password:=strPwd
    On Error Resume Next
    .ShowAllData
    .Protect _
        Contents:=True, _
        AllowFiltering:=True, _
        userinterfaceonly:=True, _
        Password:=strPwd
End With
    ''' Check user input
    
          If txtvendor.Value = "" Then
     MsgBox "You must enter the Vendor Name!", vbCritical
     Me.txtvendor.SetFocus
     Exit Sub
        End If
         
        If txtcust.Value = "" Then
     MsgBox "You must enter the Customer Name!", vbCritical
     Me.txtcust.SetFocus
     Exit Sub
        End If
        If txtSSPO.Value = "" Then
     MsgBox "You must enter the Smart Source PO number!", vbCritical
     Me.txtSSPO.SetFocus
     Exit Sub
        End If
           If txtREQSD.Value = "" Then
     MsgBox "You must enter a requested Ship Date!", vbCritical
     Me.txtREQSD.SetFocus
     Exit Sub
        End If
           
           
           
    Dim Msg As String, Ans As Variant
                      
    If txtihd.Value = "" Then
              
    Msg = "Is there an in hands date for this order??"
    Ans = MsgBox(Msg, vbYesNo)


    Select Case Ans


        Case vbYes
        Me.txtihd.SetFocus
        Exit Sub
     
        Case vbNo
        GoTo Quit:
End Select
Quit:
End If
 
     
     If drpUserSingle.Value = "" Then
     MsgBox "You must select a User!", vbCritical
     Me.drpUserSingle.SetFocus
     Exit Sub
        End If
        
        txtNotes.Value = txtNotes.Value & vbNewLine & Now & ":" & " Submitted PO"
        cbStat.Value = "Submitted"
    'find  first empty row in database
   iRow = WS.Cells(Rows.Count, 1) _
   .End(xlUp).Offset(1, 0).Row
   
   Sheets("Order Status").Unprotect Password:="2885"
   FilterOff
        ' Write data to worksheet
        
        rowCount = Worksheets("Order Status").Cells(Worksheets("Order Status").Rows.Count, 1).End(xlUp).Row
        With Worksheets("Order Status").Range("A1")
    
          .Offset(rowCount, 0).Value = Date
          .Offset(rowCount, 1).Value = Me.txtvendor.Value
          .Offset(rowCount, 2).Value = Me.txtcust.Value
          .Offset(rowCount, 3).Value = Me.txtSSPO.Value
          .Offset(rowCount, 4).Value = Me.txtVOrder.Value
          .Offset(rowCount, 5).Value = Me.txtREQSD.Value
          .Offset(rowCount, 6).Value = Me.txtihd.Value
          .Offset(rowCount, 7).Value = Me.chkREQ.Value
          .Offset(rowCount, 8).Value = Me.chkRCVD.Value
          .Offset(rowCount, 9).Value = Me.chkAPPR.Value
          .Offset(rowCount, 10).Value = Me.txtTrack.Value
          .Offset(rowCount, 11).Value = Me.txtASD.Value
          .Offset(rowCount, 12).Value = Me.cbStat.Value
          .Offset(rowCount, 13).Value = Me.txtVendEML.Value
          .Offset(rowCount, 14).Value = Me.drpUserSingle.Value
          .Offset(rowCount, 15).Value = Me.txtNotes.Value
          .Offset(rowCount, 16).Value = Me.txtLogo.Value
          .Offset(rowCount, 17).Value = Me.txtrep.Value
          .Offset(rowCount, 18).Value = Me.txtESD.Value
          End With
          
          Dim nwb As Workbook
Set nwb = Workbooks.Open("C:\Users\DReardon\Desktop\Hub Folder\HUB.xlsm")




'Determine emptyRow
Dim emptyRow As Long
emptyRow = WorksheetFunction.CountA(nwb.Sheets("Status").Range("A:A")) + 1


'Transfer Information
With nwb.Sheets("Status")
'Datebox
.Cells(emptyRow, 1).Value = txtDateSUB.Value
.Cells(emptyRow, 2).Value = txtvendor.Value
.Cells(emptyRow, 3).Value = txtcust.Value
.Cells(emptyRow, 4).Value = txtSSPO.Value
.Cells(emptyRow, 5).Value = txtVOrder.Value
.Cells(emptyRow, 6).Value = txtREQSD.Value
.Cells(emptyRow, 7).Value = txtihd.Value
.Cells(emptyRow, 8).Value = chkREQ.Value
.Cells(emptyRow, 9).Value = chkRCVD.Value
.Cells(emptyRow, 10).Value = chkAPPR.Value
.Cells(emptyRow, 11).Value = txtTrack.Value
.Cells(emptyRow, 12).Value = txtASD.Value
.Cells(emptyRow, 13).Value = cbStat.Value
.Cells(emptyRow, 14).Value = txtVendEML.Value
.Cells(emptyRow, 15).Value = drpUserSingle.Value
.Cells(emptyRow, 16).Value = txtNotes.Value
.Cells(emptyRow, 17).Value = txtLogo.Value
.Cells(emptyRow, 18).Value = txtrep.Value
.Cells(emptyRow, 19).Value = txtESD.Value


Application.DisplayAlerts = False
ActiveWorkbook.Save
ActiveWindow.Close
Application.DisplayAlerts = True
End With
                     Sheets("Order Status").Protect Password:="2885"
           
           
          Application.ScreenUpdating = False
           Columns.AutoFit
        
'VVVVVVVVV    TESTING   VVVVVVVVVVVV
Application.ScreenUpdating = False
Appointments2
Appointments3
Application.ScreenUpdating = False
ColorCellsWithIncorrectEndDate
Worksheets("Order Status").Columns("P").AutoFit
Worksheets("Order Status").Columns("P").WrapText = False
'HideShipped
'VVVVVVVVV    TESTING   VVVVVVVVVVVV


If MsgBox("Would you like to submit the PO to the vendor now?", vbYesNo) = vbNo Then Exit Sub
'Create E-mail to Vendor for PO Submit
Dim oOLook As Object
Dim oEMail As Object
Set oOLook = CreateObject("Outlook.Application")
oOLook.Session.Logon
Set oEMail = oOLook.CreateItem(0)
oEMail.Display
On Error Resume Next
With oEMail
.Importance = olImportanceHigh
.To = txtVendEML.Value
.CC = ""
.BCC = ""
.Subject = "Smart Source PO# " & txtSSPO.Value
.Body = "Hi," & vbNewLine & "Attached is Smart Source PO# " & txtSSPO.Value & "." & vbNewLine & _
"Please confirm estimated ship date, and your order # when you have a moment. Thank you and have a great day!" & vbNewLine & "Thanks," & vbNewLine & drpUserSingle.Value
End With
      Application.ScreenUpdating = True




End Sub
 

Some videos you may like

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,219
Office Version
  1. 365
Platform
  1. Windows
Don't see any major problems with that code.

Bit messy I suppose but that can be easily sorted.

Code:
Option Explicit

Private Sub cmbSubmit_Click()
Dim nwb As Workbook
Dim WS As Worksheet
Dim oOLook As Object
Dim oEMail As Object
Dim rowCount As Long
Dim ctl As Control
Dim iRow As Long
Dim emptyRow As Long
Dim Msg As String, Ans As Variant

    Set WS = Worksheets("Order Status")
    strPwd = "2885"

    With ActiveSheet
        .Unprotect Password:=strPwd
        On Error Resume Next
        .ShowAllData
        .Protect _
                Contents:=True, _
                AllowFiltering:=True, _
                userinterfaceonly:=True, _
                Password:=strPwd
    End With

    ''' Check user input
    If txtvendor.Value = "" Then
        MsgBox "You must enter the Vendor Name!", vbCritical
        Me.txtvendor.SetFocus
        Exit Sub
    End If

    If txtcust.Value = "" Then
        MsgBox "You must enter the Customer Name!", vbCritical
        Me.txtcust.SetFocus
        Exit Sub
    End If

    If txtSSPO.Value = "" Then
        MsgBox "You must enter the Smart Source PO number!", vbCritical
        Me.txtSSPO.SetFocus
        Exit Sub
    End If

    If txtREQSD.Value = "" Then
        MsgBox "You must enter a requested Ship Date!", vbCritical
        Me.txtREQSD.SetFocus
        Exit Sub
    End If

    If txtihd.Value = "" Then

        Msg = "Is there an in hands date for this order??"
        Ans = MsgBox(Msg, vbYesNo)

        Select Case Ans


            Case vbYes
                Me.txtihd.SetFocus
                Exit Sub

            Case Else
                ' do nothing
        End Select
    End If

    If drpUserSingle.Value = "" Then
        MsgBox "You must select a User!", vbCritical
        Me.drpUserSingle.SetFocus
        Exit Sub
    End If

    txtNotes.Value = txtNotes.Value & vbNewLine & Now & ":" & " Submitted PO"

    cbStat.Value = "Submitted"

    'find  first empty row in database
    iRow = WS.Cells(Rows.Count, 1) _
           .End(xlUp).Offset(1, 0).Row

    Sheets("Order Status").Unprotect Password:="2885"

    FilterOff

    ' Write data to worksheet
    rowCount = Worksheets("Order Status").Cells(Worksheets("Order Status").Rows.Count, 1).End(xlUp).Row

    With Worksheets("Order Status").Range("A1")
        .Offset(rowCount, 0).Value = Date
        .Offset(rowCount, 1).Value = Me.txtvendor.Value
        .Offset(rowCount, 2).Value = Me.txtcust.Value
        .Offset(rowCount, 3).Value = Me.txtSSPO.Value
        .Offset(rowCount, 4).Value = Me.txtVOrder.Value
        .Offset(rowCount, 5).Value = Me.txtREQSD.Value
        .Offset(rowCount, 6).Value = Me.txtihd.Value
        .Offset(rowCount, 7).Value = Me.chkREQ.Value
        .Offset(rowCount, 8).Value = Me.chkRCVD.Value
        .Offset(rowCount, 9).Value = Me.chkAPPR.Value
        .Offset(rowCount, 10).Value = Me.txtTrack.Value
        .Offset(rowCount, 11).Value = Me.txtASD.Value
        .Offset(rowCount, 12).Value = Me.cbStat.Value
        .Offset(rowCount, 13).Value = Me.txtVendEML.Value
        .Offset(rowCount, 14).Value = Me.drpUserSingle.Value
        .Offset(rowCount, 15).Value = Me.txtNotes.Value
        .Offset(rowCount, 16).Value = Me.txtLogo.Value
        .Offset(rowCount, 17).Value = Me.txtrep.Value
        .Offset(rowCount, 18).Value = Me.txtESD.Value
    End With

    Set nwb = Workbooks.Open("C:\Users\DReardon\Desktop\Hub Folder\HUB.xlsm")

    'Determine emptyRow

    emptyRow = WorksheetFunction.CountA(nwb.Sheets("Status").Range("A:A")) + 1


    'Transfer Information
    With nwb.Sheets("Status")
        'Datebox
        .Cells(emptyRow, 1).Value = txtDateSUB.Value
        .Cells(emptyRow, 2).Value = txtvendor.Value
        .Cells(emptyRow, 3).Value = txtcust.Value
        .Cells(emptyRow, 4).Value = txtSSPO.Value
        .Cells(emptyRow, 5).Value = txtVOrder.Value
        .Cells(emptyRow, 6).Value = txtREQSD.Value
        .Cells(emptyRow, 7).Value = txtihd.Value
        .Cells(emptyRow, 8).Value = chkREQ.Value
        .Cells(emptyRow, 9).Value = chkRCVD.Value
        .Cells(emptyRow, 10).Value = chkAPPR.Value
        .Cells(emptyRow, 11).Value = txtTrack.Value
        .Cells(emptyRow, 12).Value = txtASD.Value
        .Cells(emptyRow, 13).Value = cbStat.Value
        .Cells(emptyRow, 14).Value = txtVendEML.Value
        .Cells(emptyRow, 15).Value = drpUserSingle.Value
        .Cells(emptyRow, 16).Value = txtNotes.Value
        .Cells(emptyRow, 17).Value = txtLogo.Value
        .Cells(emptyRow, 18).Value = txtrep.Value
        .Cells(emptyRow, 19).Value = txtESD.Value

        Application.DisplayAlerts = False
        ActiveWorkbook.Save
        ActiveWindow.Close
        Application.DisplayAlerts = True
        
    End With
    
    Sheets("Order Status").Protect Password:="2885"

    Application.ScreenUpdating = False

    Columns.AutoFit

    'VVVVVVVVV    TESTING   VVVVVVVVVVVV
    Application.ScreenUpdating = False
    Appointments2
    Appointments3
    Application.ScreenUpdating = False

    ColorCellsWithIncorrectEndDate

    Worksheets("Order Status").Columns("P").AutoFit
    Worksheets("Order Status").Columns("P").WrapText = False

    'HideShipped
    'VVVVVVVVV    TESTING   VVVVVVVVVVVV

    If MsgBox("Would you like to submit the PO to the vendor now?", vbYesNo) = vbNo Then Exit Sub
    'Create E-mail to Vendor for PO Submit

    Set oOLook = CreateObject("Outlook.Application")
    
    oOLook.Session.Logon
    
    Set oEMail = oOLook.CreateItem(0)
    
    oEMail.Display
    
    On Error Resume Next
    
    With oEMail
        .Importance = olImportanceHigh
        .To = txtVendEML.Value
        .CC = ""
        .BCC = ""
        .Subject = "Smart Source PO# " & txtSSPO.Value
        .Body = "Hi," & vbNewLine & "Attached is Smart Source PO# " & txtSSPO.Value & "." & vbNewLine & _
                "Please confirm estimated ship date, and your order # when you have a moment. Thank you and have a great day!" & vbNewLine & "Thanks," & vbNewLine & drpUserSingle.Value
    End With

    Application.ScreenUpdating = True

End Sub

PS You might want to be careful with the On Error Resume Nexts, they could be hiding errors.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,125
Messages
5,599,850
Members
414,342
Latest member
K Darrell Smith

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
Top