A Sample of Advanced User Form VBA Coding
The application code below shows many techniques used in a robust forms application. Instead of entering data in cells, the user clicks a button to open a form and then enters the data in the form.
One advantage of a form is it is much faster to enter data, because the user can tab through controls. Also, this application used many combo boxes, and when you start entering a value in a combo box, it "auto completes", whereas drop down boxes used in normal worksheet data validation lists do not support auto complete.
Many combo boxes are used in the form, the source of which are columns of values for each combo-box control. One of the combo boxes also determines the target worksheet to receive the data.
Program Code
' ********************************************************************************* ' Demonstrate The Following Principals: ' 1) UserForm_Initialize Event Which Loads Combo Boxes ' 2) UserForm_Activate - The Earliest Point Where The Code Can Issue an "Unload Me" ' 3) Set Workbook And Worksheet Variables ' 4) Enable and Disable Form Controls ' 5) Dynamically Set Worksheet Names Using A Column Of Worksheet Names ' 6) Find Last Row of a Variable List ' 7) Load Combo Boxes Using a Universal Routine ' 8) UserForm_Terminate Event To Clean Up Global Variables ' 9) Create Edits For Textboxes That Allow Only Numeric Values ' 10) Update Cells From Form Textboxes And Convert to Numeric Doubles ' 11) Load Form Text and Combo Boxes From Cell Values ' 12) Button Click Event Processing ' 13) Date Picker Change Events ' 14) Combo Box Change Events ' 15) Create Worksheet Cell Data Validation Formulas And Enable Data Validation ' Using the "LoadDataValidation" Subroutine ' 16) Load Worksheet Cells With Formulas ' ********************************************************************************* Option Explicit Option Base 1 ' ******************************************************** ' Define Known Workbook and Worksheet Variables ' ******************************************************** Dim wkbJobSchedule As Workbook Dim wksJobSchedule As Worksheet Dim wksListDropDown As Worksheet ' ******************************************************** ' Define Variable Job Source Worksheets ' ******************************************************** Dim strJobSourceWorksheetName() As String Dim intJobSourceWorksheetIndex() As Integer Dim wksJobSource() As Worksheet Dim intJobSourceWorksheetCount As Integer Dim wksTargetWorksheet As Worksheet Dim wksTestIfSheetExists As Worksheet Dim wksJobSourceToUpdate As Worksheet ' ********************************************** ' Last Row Of ListDropDown Columns ' ********************************************** Dim lngLastTargetJobSourceWorksheetRow As Long Dim lngLastReferralRow As Long Dim lngLastETORow As Long Dim lngLastLoanRow As Long Dim lngLastCityRow As Long Dim lngLastPhonePreferenceRow As Long Dim lngLastJobTypeRow As Long Dim lngLastHomeTypeRow As Long Dim lngLastBillingSourceRow As Long Dim lngLastFluidRow As Long Dim lngLastUtilityHeatSourceRow As Long Dim lngLastAccountManagerRow As Long Dim lngLastTechRow As Long Dim lngLastBidAcceptedRow As Long Dim lngLastPWageRow As Long Dim lngLastNeedSubRow As Long Dim lngLastCoInstallRow As Long Dim lngLastMecVentInstallRow As Long Dim lngLastXOverRow As Long Dim lngLastRowOfJobSourceColorStatus As Long ' ******************************************************** ' Formulas For the Target Worksheet Drop Downs ' ******************************************************** Dim strFormulaReferral As String Dim strFormulaETO As String Dim strFormulaLoan As String Dim strFormulaCity As String Dim strFormulaPhonePreference As String Dim strFormulaJobType As String Dim strFormulaHomeType As String Dim strFormulaBillingSource As String Dim strFormulaFluid As String Dim strFormulaUtilityHeatSource As String Dim strFormulaAccountManager As String Dim strFormulaTech As String Dim strFormulaBidAccepted As String Dim strFormulaPWage As String Dim strFormulaNeedSub As String Dim strFormulaCoInstall As String Dim strFormulaMecVentInstall As String Dim strFormulaXOver As String Dim strCancel As String ' ******************************************************** ' Other Variables ' ******************************************************** Dim strJobStatus As String Dim lngColorStatusRow As Long Dim lngThemeColor As Long Dim dblTintAndShade As Double ' ******************************************************** ' From The Add Button After Form is Complete ' ******************************************************** Private Sub cmdAddJobSourceRow_Click() Dim lngNewRow As Long Dim lngLastRowOfTargetWorksheet As Long ' ******************************************************** ' Validate A Proper Target Worksheet Was Selected ' ******************************************************** If wksTargetWorksheet Is Nothing Then MsgBox ("You Must Select A Valid Job Source Worksheet") Exit Sub End If ' ******************************************************** ' Use Row "P" (Job Type) To Determine Last Row ' ******************************************************** lngLastRowOfTargetWorksheet = wksTargetWorksheet.Cells(Rows.Count, "P").End(xlUp).Row lngNewRow = lngLastRowOfTargetWorksheet + 1 If lngNewRow < 4 Then lngNewRow = 4 End If wksTargetWorksheet.Cells(lngNewRow, 1).Value = Me.dpikDateIn wksTargetWorksheet.Cells(lngNewRow, 2).Value = Me.cmbReferral wksTargetWorksheet.Cells(lngNewRow, 3).Value = Me.cmbETO wksTargetWorksheet.Cells(lngNewRow, 4).Value = Me.cmbLoan wksTargetWorksheet.Cells(lngNewRow, 5).Value = Me.txtFirstName wksTargetWorksheet.Cells(lngNewRow, 6).Value = Me.txtLastName wksTargetWorksheet.Cells(lngNewRow, 7).Value = Me.txtSiteAddress wksTargetWorksheet.Cells(lngNewRow, 8).Value = Me.txtUnit wksTargetWorksheet.Cells(lngNewRow, 9).Value = Me.cmbCity wksTargetWorksheet.Cells(lngNewRow, 10).Value = Me.txtState wksTargetWorksheet.Cells(lngNewRow, 11).Value = Me.txtZip wksTargetWorksheet.Cells(lngNewRow, 12).Value = Me.txtHomePhone wksTargetWorksheet.Cells(lngNewRow, 13).Value = Me.txtCellPhone wksTargetWorksheet.Cells(lngNewRow, 14).Value = Me.txtOtherPhone wksTargetWorksheet.Cells(lngNewRow, 15).Value = Me.cmbPhonePreference wksTargetWorksheet.Cells(lngNewRow, 16).Value = Me.cmbJobType wksTargetWorksheet.Cells(lngNewRow, 17).Value = Me.cmbHomeType If Me.txtSquareFeet <> "" Then wksTargetWorksheet.Cells(lngNewRow, 18).Value = CDbl(Me.txtSquareFeet) End If wksTargetWorksheet.Cells(lngNewRow, 19).Value = Me.cmbBillingSource wksTargetWorksheet.Cells(lngNewRow, 20).Value = Me.txtEmailAddress wksTargetWorksheet.Cells(lngNewRow, 21).Value = Me.txtMailAddress wksTargetWorksheet.Cells(lngNewRow, 22).Value = Me.cmbFluid wksTargetWorksheet.Cells(lngNewRow, 23).Value = Me.cmbUtilityHeatSource wksTargetWorksheet.Cells(lngNewRow, 24).Value = Me.cmbAccountManager wksTargetWorksheet.Cells(lngNewRow, 25).Value = Me.txtAcctNoJobPO wksTargetWorksheet.Cells(lngNewRow, 26).Value = Me.txtNotes wksTargetWorksheet.Cells(lngNewRow, 27).Value = Me.cmbTech wksTargetWorksheet.Cells(lngNewRow, 28).Value = Me.dpikBidScheduled wksTargetWorksheet.Cells(lngNewRow, 29).Value = Me.dpikBidSent wksTargetWorksheet.Cells(lngNewRow, 30).Value = Me.cmbBidAccepted wksTargetWorksheet.Cells(lngNewRow, 31).Value = Me.dpikWorkScheduled wksTargetWorksheet.Cells(lngNewRow, 32).Value = Me.cmbPWage wksTargetWorksheet.Cells(lngNewRow, 33).Value = Me.cmbNeedSub wksTargetWorksheet.Cells(lngNewRow, 34).Value = Me.dpikSubScheduled wksTargetWorksheet.Cells(lngNewRow, 35).FormulaR1C1 = "=RC[-19]" If Me.txtCostPerService <> "" Then wksTargetWorksheet.Cells(lngNewRow, 36).Value = CDbl(Me.txtCostPerService) End If wksTargetWorksheet.Cells(lngNewRow, 37).Value = Me.dpikDownPaymentReceived wksTargetWorksheet.Cells(lngNewRow, 38).Value = Me.dpikInvoiced wksTargetWorksheet.Cells(lngNewRow, 39).Value = Me.dpikCustResponseSent wksTargetWorksheet.Cells(lngNewRow, 40).Value = Me.dpikPaymentReceived wksTargetWorksheet.Cells(lngNewRow, 41).Value = Me.dpikThankYouSent If Me.txtSANum <> "" Then wksTargetWorksheet.Cells(lngNewRow, 42).Value = CDbl(Me.txtSANum) End If If Me.txtRANum <> "" Then wksTargetWorksheet.Cells(lngNewRow, 43).Value = CDbl(Me.txtRANum) End If wksTargetWorksheet.Cells(lngNewRow, 44).FormulaR1C1 = "=IF(RC[-2]+RC[-1],RC[-2]+RC[-1],0)" wksTargetWorksheet.Cells(lngNewRow, 45).FormulaR1C1 = "=IF(RC[-1]<>0,RC[-9]/RC[-1],0)" wksTargetWorksheet.Cells(lngNewRow, 46).FormulaR1C1 = "=RC[-28]" If Me.txtPreDWRTO <> "" Then wksTargetWorksheet.Cells(lngNewRow, 47).Value = CDbl(Me.txtPreDWRTO) End If If Me.txtPostDWRTO <> "" Then wksTargetWorksheet.Cells(lngNewRow, 48).Value = CDbl(Me.txtPostDWRTO) End If wksTargetWorksheet.Cells(lngNewRow, 49).FormulaR1C1 = "=SUM(RC[-3]*0.1)" wksTargetWorksheet.Cells(lngNewRow, 50).FormulaR1C1 = "=SUM(RC[-3]-RC[-2])" wksTargetWorksheet.Cells(lngNewRow, 51).FormulaR1C1 = "=IF(RC[-4]<>0,SUM(RC[-1]/RC[-4]),0)" If Me.txtPreHouse <> "" Then wksTargetWorksheet.Cells(lngNewRow, 52).Value = CDbl(Me.txtPreHouse) End If If Me.txtPostBD <> "" Then wksTargetWorksheet.Cells(lngNewRow, 53).Value = CDbl(Me.txtPostBD) End If wksTargetWorksheet.Cells(lngNewRow, 54).FormulaR1C1 = "=SUM(RC[-2]-RC[-1])" wksTargetWorksheet.Cells(lngNewRow, 55).FormulaR1C1 = "=IF(RC[-3]<>0,SUM(RC[-1]/RC[-3]),0)" wksTargetWorksheet.Cells(lngNewRow, 56).Value = Me.txtPressureTabLoc wksTargetWorksheet.Cells(lngNewRow, 57).Value = Me.txtDBLocation wksTargetWorksheet.Cells(lngNewRow, 58).Value = Me.txtBDLocation If Me.txtVolume <> "" Then wksTargetWorksheet.Cells(lngNewRow, 59).Value = CDbl(Me.txtVolume) End If wksTargetWorksheet.Cells(lngNewRow, 60).FormulaR1C1 = "=IF(RC[-1]<>0,SUM((60/RC[-1])*RC[-8]),0)" wksTargetWorksheet.Cells(lngNewRow, 61).FormulaR1C1 = "=IF(RC[-2]<>0,SUM((60/RC[-2])*RC[-8]),0)" wksTargetWorksheet.Cells(lngNewRow, 62).Value = Me.cmbCoInstall wksTargetWorksheet.Cells(lngNewRow, 63).Value = Me.cmbMecVentInstall wksTargetWorksheet.Cells(lngNewRow, 64).Value = Me.cmbXOver ' ********************************************************************* ' Create the Drop Down Formulas for the Actual Worksheet ' ********************************************************************* strFormulaReferral = "=ListDropDown!$A$4:$A$" & lngLastReferralRow strFormulaETO = "=ListDropDown!$B$4:$B$" & lngLastETORow strFormulaLoan = "=ListDropDown!$C$4:$C$" & lngLastLoanRow strFormulaCity = "=ListDropDown!$D$4:$D$" & lngLastCityRow strFormulaPhonePreference = "=ListDropDown!$E$4:$E$" & lngLastPhonePreferenceRow strFormulaJobType = "=ListDropDown!$F$4:$F$" & lngLastJobTypeRow strFormulaHomeType = "=ListDropDown!$G$4:$G$" & lngLastHomeTypeRow strFormulaBillingSource = "=ListDropDown!$H$4:$H$" & lngLastBillingSourceRow strFormulaFluid = "=ListDropDown!$I$4:$I$" & lngLastFluidRow strFormulaUtilityHeatSource = "=ListDropDown!$J$4:$J$" & lngLastUtilityHeatSourceRow strFormulaAccountManager = "=ListDropDown!$K$4:$K$" & lngLastAccountManagerRow strFormulaTech = "=ListDropDown!$L$4:$L$" & lngLastTechRow strFormulaBidAccepted = "=ListDropDown!$P$4:$P$" & lngLastBidAcceptedRow strFormulaPWage = "=ListDropDown!$Q$4:$Q$" & lngLastPWageRow strFormulaNeedSub = "=ListDropDown!$R$4:$R$" & lngLastNeedSubRow strFormulaCoInstall = "=ListDropDown!$S$4:$S$" & lngLastCoInstallRow strFormulaMecVentInstall = "=ListDropDown!$T$4:$T$" & lngLastMecVentInstallRow strFormulaXOver = "=ListDropDown!$U$4:$U$" & lngLastXOverRow ' ********************************************************************* ' Populate The Drop Downs On The Target Worksheet Row ' Note That "True" Restricts Values To The List Only ' ********************************************************************* Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 2&, strFormulaReferral, False) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 3&, strFormulaETO, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 4&, strFormulaLoan, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 9&, strFormulaCity, False) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 15&, strFormulaPhonePreference, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 16&, strFormulaJobType, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 17&, strFormulaHomeType, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 19&, strFormulaBillingSource, False) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 22&, strFormulaFluid, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 23&, strFormulaUtilityHeatSource, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 24&, strFormulaAccountManager, False) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 27&, strFormulaTech, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 30&, strFormulaBidAccepted, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 32&, strFormulaPWage, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 33&, strFormulaNeedSub, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 62&, strFormulaCoInstall, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 63&, strFormulaMecVentInstall, True) Call LoadDataValidation(wksTargetWorksheet, lngNewRow, 64&, strFormulaXOver, True) ' ********************************************************************* ' Set Color For New ' ********************************************************************* lngColorStatusRow = GetJobStatusColorRow(strJobStatus) If lngColorStatusRow <> 0 Then ' ******************************************************** ' Color Code The Line ' ******************************************************** On Error GoTo ColorSelectionNotValid lngThemeColor = wksListDropDown.Cells(lngColorStatusRow, 25).Interior.ThemeColor dblTintAndShade = wksListDropDown.Cells(lngColorStatusRow, 25).Interior.TintAndShade Range(wksTargetWorksheet.Cells(lngNewRow, 1), wksTargetWorksheet.Cells(lngNewRow, 64)).Interior.ThemeColor = lngThemeColor Range(wksTargetWorksheet.Cells(lngNewRow, 1), wksTargetWorksheet.Cells(lngNewRow, 64)).Interior.TintAndShade = dblTintAndShade On Error GoTo 0 Unload Me Exit Sub Else Unload Me Exit Sub End If ' ******************************************************** ' Incorrect Color Selected ' ******************************************************** ColorSelectionNotValid: MsgBox ("1> You Must Select a Theme Color For Job Status Change, Not a Standard Color" & vbCrLf & _ "2> Change The Color Scheme in ListDropDown to a Theme Color And Retry") On Error GoTo 0 Unload Me Exit Sub End Sub Private Sub cmbTargetJobSourceWorksheet_Change() ' ********************************************** ' Set Up The Target Worksheet As The ' Recipient of All Form Data Entered ' ********************************************** Dim i As Integer Set wksTargetWorksheet = Nothing For i = 1 To UBound(strJobSourceWorksheetName) If Me.cmbTargetJobSourceWorksheet.Value = strJobSourceWorksheetName(i) Then Set wksTargetWorksheet = wksJobSource(i) Exit For End If Next i End Sub Private Sub cmdCancelChanges_Click() ' *********************************************** ' Do Not Apply Any Adds Or Updates ' *********************************************** ' ********************************************************************* ' Unload The Form And Clear The Job Source Variables ' In The Form Exit Event ' ********************************************************************* Unload Me End Sub Private Sub cmdUpdateJobSourceRow_Click() ' *********************************************** ' Update The Worksheet Row With New Values ' *********************************************** wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 1).Value = Me.dpikDateIn wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 2).Value = Me.cmbReferral wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 3).Value = Me.cmbETO wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 4).Value = Me.cmbLoan wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 5).Value = Me.txtFirstName wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 6).Value = Me.txtLastName wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 7).Value = Me.txtSiteAddress wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 8).Value = Me.txtUnit wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 9).Value = Me.cmbCity wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 10).Value = Me.txtState wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 11).Value = Me.txtZip wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 12).Value = Me.txtHomePhone wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 13).Value = Me.txtCellPhone wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 14).Value = Me.txtOtherPhone wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 15).Value = Me.cmbPhonePreference wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 16).Value = Me.cmbJobType wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 17).Value = Me.cmbHomeType If Me.txtSquareFeet = "" Then If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 18).Value <> 0 Then wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 18).Value = "" End If Else wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 18).Value = CDbl(Me.txtSquareFeet) End If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 19).Value = Me.cmbBillingSource wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 20).Value = Me.txtEmailAddress wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 21).Value = Me.txtMailAddress wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 22).Value = Me.cmbFluid wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 23).Value = Me.cmbUtilityHeatSource wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 24).Value = Me.cmbAccountManager wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 25).Value = Me.txtAcctNoJobPO wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 26).Value = Me.txtNotes wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 27).Value = Me.cmbTech wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 28).Value = Me.dpikBidScheduled wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 29).Value = Me.dpikBidSent wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 30).Value = Me.cmbBidAccepted wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 31).Value = Me.dpikWorkScheduled wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 32).Value = Me.cmbPWage wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 33).Value = Me.cmbNeedSub wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 34).Value = Me.dpikSubScheduled If Me.txtCostPerService = "" Then If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 36).Value <> 0 Then wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 36).Value = "" End If Else wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 36).Value = CDbl(Me.txtCostPerService) End If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 37).Value = Me.dpikDownPaymentReceived wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 38).Value = Me.dpikInvoiced wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 39).Value = Me.dpikCustResponseSent wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 40).Value = Me.dpikPaymentReceived wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 41).Value = Me.dpikThankYouSent If Me.txtSANum = "" Then If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 42).Value <> 0 Then wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 42).Value = "" End If Else wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 42).Value = CDbl(Me.txtSANum) End If If Me.txtRANum = "" Then If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 43).Value <> 0 Then wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 43).Value = "" End If Else wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 43).Value = CDbl(Me.txtRANum) End If If Me.txtPreDWRTO = "" Then If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 47).Value <> 0 Then wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 47).Value = "" End If Else wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 47).Value = CDbl(Me.txtPreDWRTO) End If If Me.txtPostDWRTO = "" Then If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 48).Value <> 0 Then wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 48).Value = "" End If Else wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 48).Value = CDbl(Me.txtPostDWRTO) End If If Me.txtPreHouse = "" Then If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 52).Value <> 0 Then wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 52).Value = "" End If Else wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 52).Value = CDbl(Me.txtPreHouse) End If If Me.txtPostBD = "" Then If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 53).Value <> 0 Then wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 53).Value = "" End If Else wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 53).Value = CDbl(Me.txtPostBD) End If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 56).Value = Me.txtPressureTabLoc wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 57).Value = Me.txtDBLocation wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 58).Value = Me.txtBDLocation If Me.txtVolume = "" Then If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 59).Value <> 0 Then wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 59).Value = "" End If Else wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 59).Value = CDbl(Me.txtVolume) End If wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 62).Value = Me.cmbCoInstall wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 63).Value = Me.cmbMecVentInstall wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 64).Value = Me.cmbXOver ' ********************************************************************* ' Change Status Color If Any Key Dates Changed ' ********************************************************************* lngColorStatusRow = GetJobStatusColorRow(strJobStatus) If lngColorStatusRow <> 0 Then ' ******************************************************** ' Color Code The Line ' ******************************************************** On Error GoTo ColorSelectionNotValid lngThemeColor = wksListDropDown.Cells(lngColorStatusRow, 25).Interior.ThemeColor dblTintAndShade = wksListDropDown.Cells(lngColorStatusRow, 25).Interior.TintAndShade Range(wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 1), wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 64)).Interior.ThemeColor = lngThemeColor Range(wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 1), wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 64)).Interior.TintAndShade = dblTintAndShade On Error GoTo 0 strJobSourceNameToBeUpdated = "" lngJobSourceRowToUpdate = 0 Unload Me Exit Sub Else strJobSourceNameToBeUpdated = "" lngJobSourceRowToUpdate = 0 Unload Me Exit Sub End If ' ******************************************************** ' Incorrect Color Selected ' ******************************************************** ColorSelectionNotValid: MsgBox ("1> You Must Select a Theme Color For Job Status Change, Not a Standard Color" & vbCrLf & _ "2> Change The Color Scheme in ListDropDown to a Theme Color And Retry") On Error GoTo 0 strJobSourceNameToBeUpdated = "" lngJobSourceRowToUpdate = 0 Unload Me Exit Sub End Sub Private Sub txtCostPerService_Exit(ByVal Cancel As MSForms.ReturnBoolean) AllowOnlyNumbers If strCancel = "Y" Then Cancel = True End If End Sub Private Sub txtPostBD_Exit(ByVal Cancel As MSForms.ReturnBoolean) AllowOnlyNumbers If strCancel = "Y" Then Cancel = True End If End Sub Private Sub txtPostDWRTO_Exit(ByVal Cancel As MSForms.ReturnBoolean) AllowOnlyNumbers If strCancel = "Y" Then Cancel = True End If End Sub Private Sub txtPreDWRTO_Exit(ByVal Cancel As MSForms.ReturnBoolean) AllowOnlyNumbers If strCancel = "Y" Then Cancel = True End If End Sub Private Sub txtPreHouse_Exit(ByVal Cancel As MSForms.ReturnBoolean) AllowOnlyNumbers If strCancel = "Y" Then Cancel = True End If End Sub Private Sub txtRANum_Exit(ByVal Cancel As MSForms.ReturnBoolean) AllowOnlyNumbers If strCancel = "Y" Then Cancel = True End If End Sub Private Sub txtSANum_Exit(ByVal Cancel As MSForms.ReturnBoolean) AllowOnlyNumbers If strCancel = "Y" Then Cancel = True End If End Sub Private Sub txtSquareFeet_Exit(ByVal Cancel As MSForms.ReturnBoolean) AllowOnlyNumbers If strCancel = "Y" Then Cancel = True End If End Sub Private Sub txtVolume_Exit(ByVal Cancel As MSForms.ReturnBoolean) AllowOnlyNumbers If strCancel = "Y" Then Cancel = True End If End Sub Private Sub dpikBidScheduled_Change() ' ******************************************************** ' Bid Scheduled Date Changed ' ******************************************************** strJobStatus = "Bid Scheduled" End Sub Private Sub dpikWorkScheduled_Change() ' ******************************************************** ' Work Scheduled Date Changed ' ******************************************************** strJobStatus = "Work Scheduled" End Sub Private Sub dpikInvoiced_Change() ' ******************************************************** ' Work Was Invoiced ' ******************************************************** strJobStatus = "Invoiced" End Sub Private Sub dpikPaymentReceived_Change() ' ******************************************************** ' Payment Received ' ******************************************************** strJobStatus = "Payment Received" End Sub Private Sub UserForm_Activate() ' ********************************************************************* ' Unload The Form If Requested ' ********************************************************************* If strUnloadMe = "Y" Then strUnloadMe = "N" Unload Me Exit Sub End If End Sub Private Sub UserForm_Initialize() ' ********************************************** ' This is triggered by the Excel Form Open Event ' ********************************************** Dim i As Long ' *********************************************** ' Initialize The Workbook and Worksheet Variables ' *********************************************** Set wkbJobSchedule = ThisWorkbook Set wksJobSchedule = wkbJobSchedule.Sheets("Schedule") Set wksListDropDown = wkbJobSchedule.Sheets("ListDropDown") Set wksTargetWorksheet = Nothing ' ********************************************************************* ' Find The Template Names From Column 23 And Load An Array of ' Job Source Worksheets. Since the number of worksheets can vary, ' This method allows adding new worksheets without VBA Changes ' ********************************************************************* With Me.cmbTargetJobSourceWorksheet .Enabled = True .Locked = False End With Me.lblErrorMessage.Visible = False strJobStatus = "" intJobSourceWorksheetCount = 0 lngLastTargetJobSourceWorksheetRow = wksListDropDown.Cells(Rows.Count, "W").End(xlUp).Row For i = 4 To lngLastTargetJobSourceWorksheetRow On Error Resume Next Set wksTestIfSheetExists = Nothing Set wksTestIfSheetExists = Sheets(wksListDropDown.Cells(i, 23).Value) If wksTestIfSheetExists Is Nothing Then MsgBox ("Job Source Worksheet " & wksListDropDown.Cells(i, 23).Value & " Does Not Exist") Err.Clear Else On Error GoTo 0 intJobSourceWorksheetCount = intJobSourceWorksheetCount + 1 ReDim Preserve strJobSourceWorksheetName(1 To intJobSourceWorksheetCount) ReDim Preserve intJobSourceWorksheetIndex(1 To intJobSourceWorksheetCount) ReDim Preserve wksJobSource(1 To intJobSourceWorksheetCount) strJobSourceWorksheetName(intJobSourceWorksheetCount) = wksListDropDown.Cells(i, 23).Value intJobSourceWorksheetIndex(intJobSourceWorksheetCount) = wksTestIfSheetExists.Index Set wksJobSource(intJobSourceWorksheetCount) = Sheets(intJobSourceWorksheetIndex(intJobSourceWorksheetCount)) End If Next i On Error GoTo 0 ' ********************************************************************* ' Find The Last Row For Each Drop Down ' ********************************************************************* lngLastReferralRow = wksListDropDown.Cells(Rows.Count, "A").End(xlUp).Row lngLastETORow = wksListDropDown.Cells(Rows.Count, "B").End(xlUp).Row lngLastLoanRow = wksListDropDown.Cells(Rows.Count, "C").End(xlUp).Row lngLastCityRow = wksListDropDown.Cells(Rows.Count, "D").End(xlUp).Row lngLastPhonePreferenceRow = wksListDropDown.Cells(Rows.Count, "E").End(xlUp).Row lngLastJobTypeRow = wksListDropDown.Cells(Rows.Count, "F").End(xlUp).Row lngLastHomeTypeRow = wksListDropDown.Cells(Rows.Count, "G").End(xlUp).Row lngLastBillingSourceRow = wksListDropDown.Cells(Rows.Count, "H").End(xlUp).Row lngLastFluidRow = wksListDropDown.Cells(Rows.Count, "I").End(xlUp).Row lngLastUtilityHeatSourceRow = wksListDropDown.Cells(Rows.Count, "J").End(xlUp).Row lngLastAccountManagerRow = wksListDropDown.Cells(Rows.Count, "K").End(xlUp).Row lngLastTechRow = wksListDropDown.Cells(Rows.Count, "L").End(xlUp).Row lngLastBidAcceptedRow = wksListDropDown.Cells(Rows.Count, "P").End(xlUp).Row lngLastPWageRow = wksListDropDown.Cells(Rows.Count, "Q").End(xlUp).Row lngLastNeedSubRow = wksListDropDown.Cells(Rows.Count, "R").End(xlUp).Row lngLastCoInstallRow = wksListDropDown.Cells(Rows.Count, "S").End(xlUp).Row lngLastMecVentInstallRow = wksListDropDown.Cells(Rows.Count, "T").End(xlUp).Row lngLastXOverRow = wksListDropDown.Cells(Rows.Count, "U").End(xlUp).Row lngLastRowOfJobSourceColorStatus = wksListDropDown.Cells(Rows.Count, "X").End(xlUp).Row ' ********************************************************************* ' Load The Combo Boxes for the Job Intake Form ' ********************************************************************* Call LoadComboBox(wksListDropDown, 1, 4, lngLastReferralRow, cmbReferral) Call LoadComboBox(wksListDropDown, 2, 4, lngLastETORow, cmbETO) Call LoadComboBox(wksListDropDown, 3, 4, lngLastLoanRow, cmbLoan) Call LoadComboBox(wksListDropDown, 4, 4, lngLastCityRow, cmbCity) Call LoadComboBox(wksListDropDown, 5, 4, lngLastPhonePreferenceRow, cmbPhonePreference) Call LoadComboBox(wksListDropDown, 6, 4, lngLastJobTypeRow, cmbJobType) Call LoadComboBox(wksListDropDown, 7, 4, lngLastHomeTypeRow, cmbHomeType) Call LoadComboBox(wksListDropDown, 8, 4, lngLastBillingSourceRow, cmbBillingSource) Call LoadComboBox(wksListDropDown, 9, 4, lngLastFluidRow, cmbFluid) Call LoadComboBox(wksListDropDown, 10, 4, lngLastUtilityHeatSourceRow, cmbUtilityHeatSource) Call LoadComboBox(wksListDropDown, 11, 4, lngLastAccountManagerRow, cmbAccountManager) Call LoadComboBox(wksListDropDown, 12, 4, lngLastTechRow, cmbTech) Call LoadComboBox(wksListDropDown, 16, 4, lngLastBidAcceptedRow, cmbBidAccepted) Call LoadComboBox(wksListDropDown, 17, 4, lngLastPWageRow, cmbPWage) Call LoadComboBox(wksListDropDown, 18, 4, lngLastNeedSubRow, cmbNeedSub) Call LoadComboBox(wksListDropDown, 19, 4, lngLastCoInstallRow, cmbCoInstall) Call LoadComboBox(wksListDropDown, 20, 4, lngLastMecVentInstallRow, cmbMecVentInstall) Call LoadComboBox(wksListDropDown, 21, 4, lngLastXOverRow, cmbXOver) Call LoadComboBox(wksListDropDown, 23, 4, lngLastTargetJobSourceWorksheetRow, cmbTargetJobSourceWorksheet) ' ********************************************************************* ' Prepare Form For Adding A New Line ' ********************************************************************* If strTypeOfProcessing = "A" Then Me.txtState = "OR" strJobStatus = "New" Me.cmdUpdateJobSourceRow.Visible = False Me.cmdUpdateJobSourceRow.Enabled = False Me.cmdAddJobSourceRow.Visible = True Me.cmdAddJobSourceRow.Enabled = True Exit Sub Else Me.cmdUpdateJobSourceRow.Visible = True Me.cmdUpdateJobSourceRow.Enabled = True Me.cmdAddJobSourceRow.Visible = False Me.cmdAddJobSourceRow.Enabled = False End If ' ********************************************************************* ' Prepare Form For Updating An Existing Line ' ********************************************************************* ' strJobSourceNameToBeUpdated Is Updated By The following module: ' aSelectJobSourceRowForUpdate Which Must Be Initialized by Alt-F8 ' Also, lngJobSourceRowToUpdate Is Also Updated By The Same Module ' ********************************************************************* If lngJobSourceRowToUpdate = 0 Or strJobSourceNameToBeUpdated = "" Then MsgBox ("1> You Must Select A Job Source Cell" & vbCrLf & _ "2> Then Press Alt-F8 To Run The Macro Called a_MarkJobSourceLocation" & vbCrLf & _ "3> Then Click The 'Update Job Source Row' Button") strJobSourceNameToBeUpdated = "" lngJobSourceRowToUpdate = 0 strUnloadMe = "Y" Exit Sub End If ' ********************************************************************* ' See If A Valid Job Source Worksheet Was Selected ' ********************************************************************* Set wksJobSourceToUpdate = Nothing For i = 1 To UBound(strJobSourceWorksheetName) If strJobSourceNameToBeUpdated = strJobSourceWorksheetName(i) Then Set wksJobSourceToUpdate = wksJobSource(i) Exit For End If Next i If wksJobSourceToUpdate Is Nothing Then MsgBox ("1> You Must Select A Job Source Cell" & vbCrLf & _ "2> Then Press Alt-F8 To Run The Macro Called a_MarkJobSourceLocation" & vbCrLf & _ "3> Then Click The 'Update Job Source Row' Button") strJobSourceNameToBeUpdated = "" lngJobSourceRowToUpdate = 0 strUnloadMe = "Y" Exit Sub End If ' ********************************************************************* ' Load The Form With Job Source Data ' ********************************************************************* With Me.cmbTargetJobSourceWorksheet .Value = wksJobSourceToUpdate.Name .Enabled = False .Locked = True End With Me.dpikDateIn = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 1).Value Me.cmbReferral = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 2).Value Me.cmbETO = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 3).Value Me.cmbLoan = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 4).Value Me.txtFirstName = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 5).Value Me.txtLastName = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 6).Value Me.txtSiteAddress = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 7).Value Me.txtUnit = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 8).Value Me.cmbCity = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 9).Value Me.txtState = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 10).Value Me.txtZip = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 11).Value Me.txtHomePhone = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 12).Value Me.txtCellPhone = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 13).Value Me.txtOtherPhone = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 14).Value Me.cmbPhonePreference = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 15).Value Me.cmbJobType = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 16).Value Me.cmbHomeType = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 17).Value Me.txtSquareFeet = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 18).Value Me.cmbBillingSource = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 19).Value Me.txtEmailAddress = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 20).Value Me.txtMailAddress = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 21).Value Me.cmbFluid = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 22).Value Me.cmbUtilityHeatSource = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 23).Value Me.cmbAccountManager = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 24).Value Me.txtAcctNoJobPO = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 25).Value Me.txtNotes = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 26).Value Me.cmbTech = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 27).Value Me.dpikBidScheduled = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 28).Value Me.dpikBidSent = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 29).Value Me.cmbBidAccepted = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 30).Value Me.dpikWorkScheduled = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 31).Value Me.cmbPWage = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 32).Value Me.cmbNeedSub = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 33).Value Me.dpikSubScheduled = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 34).Value Me.txtCostPerService = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 36).Value Me.dpikDownPaymentReceived = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 37).Value Me.dpikInvoiced = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 38).Value Me.dpikCustResponseSent = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 39).Value Me.dpikPaymentReceived = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 40).Value Me.dpikThankYouSent = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 41).Value Me.txtSANum = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 42).Value Me.txtRANum = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 43).Value Me.txtPreDWRTO = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 47).Value Me.txtPostDWRTO = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 48).Value Me.txtPreHouse = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 52).Value Me.txtPostBD = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 53).Value Me.txtPressureTabLoc = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 56).Value Me.txtDBLocation = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 57).Value Me.txtBDLocation = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 58).Value Me.txtVolume = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 59).Value Me.cmbCoInstall = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 62).Value Me.cmbMecVentInstall = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 63).Value Me.cmbXOver = wksJobSourceToUpdate.Cells(lngJobSourceRowToUpdate, 64).Value End Sub Private Sub LoadComboBox(ProfileWorksheet As Worksheet, ColumnNumber As Long, BeginningRow As Long, EndingRow As Long, TargetComboBox As ComboBox) Dim i As Long TargetComboBox.Clear For i = BeginningRow To EndingRow TargetComboBox.AddItem (ProfileWorksheet.Cells(i, ColumnNumber)) Next i End Sub Private Sub AllowOnlyNumbers() strCancel = "N" Me.lblErrorMessage.Visible = False If TypeName(Me.ActiveControl) = "TextBox" Then With Me.ActiveControl If Not IsNumeric(.Value) And .Value <> vbNullString Then Me.lblErrorMessage.Visible = True .Value = vbNullString strCancel = "Y" End If End With End If End Sub Private Sub UserForm_Terminate() strJobSourceNameToBeUpdated = "" lngJobSourceRowToUpdate = 0 End Sub Private Function GetJobStatusColorRow(JobStatus As String) As Long Dim i As Long For i = 4 To lngLastRowOfJobSourceColorStatus If JobStatus = wksListDropDown.Cells(i, 24) Then GetJobStatusColorRow = i Exit Function End If Next i GetJobStatusColorRow = 0 End Function