I have created a Userform, which is working fine, Wills for Safe Keeping and decided to add some additional functionality.
I would like for the County, City and State fields to populate when the Zip Code is entered. I have created a separate workbook to get this feature to work, which it is.
Now, I am not sure how to combine the two.
Any assistance would be GREATLY APPRECIATED!
Wills for Safe Keeping
Zip Code - County, City, State
Current Code for Zip Code function:
Wills for Safe Keeping Current Code:
I would like for the County, City and State fields to populate when the Zip Code is entered. I have created a separate workbook to get this feature to work, which it is.
Now, I am not sure how to combine the two.
Any assistance would be GREATLY APPRECIATED!
Wills for Safe Keeping
- User Form screen shot -
https://drive.google.com/open?id=14Gs-3orcfp8V1bXSLMkwkUWJYZZdIQ6K
- Workbook with vba code - see below
Zip Code - County, City, State
- User form screen shot - https://drive.google.com/open?id=1sb7I5DhKyikJqeaTuLkg1vqJDOylFbEi
- Workbook with vba code - see below
Current Code for Zip Code function:
Code:
Option Explicit
Private Sub Auto_Open()
UserForm1.Show
End Sub
Private Sub CommandButton1_Click()
Dim irow As Long
Dim ws As Worksheet
Dim Rng As Range
Set ws = Worksheets("DataSource")
Set Rng = ws.Range("A2")
irow = Selection.Row
ws.Cells(irow, 1) = ref.Value
ws.Cells(irow, 2) = txtcounty.Value
ws.Cells(irow, 3) = txtcity.Value
ws.Cells(irow, 4) = txtstate.Value
Unload Me
End Sub
Private Sub ref_Change()
Dim MyName As String, myRange As Range
Dim found As Range
MyName = Me.ref.Text
Set myRange = ThisWorkbook.Sheets("listsheet").Range("A:A")
Set found = myRange.Find(MyName, LookIn:=xlValues, LookAt:=xlWhole)
If Not found Is Nothing Then
Me.txtcounty.Text = found.Offset(, 1)
Me.txtcity.Text = found.Offset(, 2)
Me.txtstate.Text = found.Offset(, 3)
Else
Me.txtcounty = ""
Me.txtcity = ""
Me.txtstate = ""
End If
End Sub
Private Sub UserForm_Initialize()
Dim ws As Worksheet
Set ws = Worksheets("DataSource")
Dim irow As Long
irow = Selection.Row
UserForm.ref.Text = ws.Cells(irow, 1)
UserForm.txtcounty.Text = ws.Cells(irow, 2)
UserForm.txtcity.Text = ws.Cells(irow, 3)
UserForm.txtstate.Text = ws.Cells(irow, 4)
End SubWills for Safe Keeping Current Code:
Code:
Sub Clear()
Dim ctl As Control
For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox"
ctl.Text = ""
Case "ListBox"
ctl.RowSource = ""
Case "ComboBox"
ctl.Value = ""
End Select
Next ctl
End Sub
Private Sub cboHeader_Change()
'dim the variable
Dim DataSH As Worksheet
'set the variable
Set DataSH = Sheet1
'establish the condition for "All_Columns"
If Me.cboHeader.Value = "All_Columns" Then
DataSH.Range("AA8") = ""
Else
'clear the textbox
Me.txtAllColumn = ""
'add the criteria header to the sheet
DataSH.Range("AA8") = Me.cboHeader.Value
'clear any existing criteria
DataSH.Range("AA9") = ""
End If
End Sub
Private Sub cmdAdd_Click()
'dimention the variable
Dim DataSH As Worksheet
Dim Addme As Range
'set the variable
Set DataSH = Sheet1
'error handler
On Error GoTo errHandler:
'set variable for the destination
Set Addme = DataSH.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
If Me.txtFileNumber = "" Or Me.txtLastName = "" Then
MsgBox "There is insufficient data to add file. File Number, Last Name are required."
Exit Sub
End If
'send the values to the database
With DataSH
'add the unique reference ID then all other values
Addme.Offset(0, -1) = DataSH.Range("C6").Value + 1
Addme.Value = Me.txtFileNumber
Addme.Offset(0, 1).Value = Me.txtCodicilNumber
Addme.Offset(0, 2).Value = Me.txtDateReceived
Addme.Offset(0, 3).Value = Me.txtLastName
Addme.Offset(0, 4).Value = Me.txtFirstName
Addme.Offset(0, 5).Value = Me.txtMiddleName
Addme.Offset(0, 6).Value = Me.txtAddress
Addme.Offset(0, 7).Value = Me.txtAddress2
Addme.Offset(0, 8).Value = Me.txtCity
Addme.Offset(0, 9).Value = Me.txtState
Addme.Offset(0, 10).Value = Me.txtZipCode
Addme.Offset(0, 11).Value = Me.txtPhone
Addme.Offset(0, 12).Value = Me.txtMobile
Addme.Offset(0, 13).Value = Me.txtEmail
Addme.Offset(0, 14).Value = Me.txtCountyTxfrTo
Addme.Offset(0, 15).Value = Me.txtDateTxfr
Addme.Offset(0, 16).Value = Me.txtDateRemoved
Addme.Offset(0, 17).Value = Me.txtReasonRemoved
Addme.Offset(0, 18).Value = Me.txtGivenTo
Addme.Offset(0, 19).Value = Me.txtComments
End With
'sort the data by "LastName"
DataSH.Select
With DataSH
.Range("B9:V10000").Sort Key1:=Range("F9"), Order1:=xlAscending, Header:=xlGuess
End With
'clear the values after entry
Clear
'communicate with the user
MsgBox "File data was successfully added"
'return to interface sheet sheet
Sheet2.Select
'reset the form
On Error GoTo 0
Exit Sub
errHandler:
'if error occurs then show me exactly where the error occurs
MsgBox "Error " & Err.Number & _
" (" & Err.Description & ")in procedure cmdClear_Click of Form WillsData"
End Sub
Private Sub cmdClear_Click()
Dim ctl As Control
For Each ctl In Me.Controls
Select Case TypeName(ctl)
Case "TextBox"
ctl.Text = ""
Case "ListBox"
ctl.RowSource = ""
Case "ComboBox"
ctl.Value = ""
End Select
Next ctl
End Sub
Private Sub cmdClose_Click()
'close the form
Unload Me
End Sub
Private Sub cmdContact_Click()
'dim the variables
Dim Crit As Range
Dim FindMe As Range
Dim DataSH As Worksheet
'error handler
On Error GoTo errHandler:
'set object variables
Set DataSH = Sheet1
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
'///////////////////////////////////////////
'if header is selected add the criteria
If Me.cboHeader.Value <> "All_Columns" Then
If Me.txtSearch = "" Then
DataSH.Range("AA9") = ""
Else
DataSH.Range("AA9") = "*" & Me.txtSearch.Value & "*"
End If
End If
'//////////////////////////////////////////
'if all columns is selected
If Me.cboHeader.Value = "All_Columns" Then
'find the value in the column
Set FindMe = DataSH.Range("B9:V10000").Find(What:=txtSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'variable for criteria header
Set Crit = DataSH.Cells(8, FindMe.Column)
'if no criteria is added to the search
If Me.txtSearch = "" Then
DataSH.Range("AA9") = ""
DataSH.Range("AA8") = ""
Else
'add values from the search
DataSH.Range("AA8") = Crit
If Crit = "ID" Then
DataSH.Range("AA9") = Me.txtSearch.Value
Else
DataSH.Range("AA9") = "*" & Me.txtSearch.Value & "*"
End If
'show in the userform the header that is added
Me.txtAllColumn = DataSH.Range("AA8").Value
End If
End If
'/////////////////////////////////////////
'unprotect all sheets
'Unprotect_All
'filter the data
DataSH.Range("B8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Data!$AA$8:$AA$9"), CopyToRange:=Range("Data!$AC$8:$AW$8"), _
Unique:=False
'add the dynamic data to the listbox
lstWill.RowSource = DataSH.Range("outdata").Address(external:=True)
'protect all sheets
'Protect_All
'error handler
On Error GoTo 0
Exit Sub
errHandler:
'Protect all sheets
'Protect_All
'if error occurs then show me exactly where the error occurs
MsgBox "No match found for " & txtSearch.Text
'clear the listbox if no match is found
Me.lstWill.RowSource = ""
Exit Sub
End Sub
Private Sub cmdDelete_Click()
'declare the variables
Dim findvalue As Range
Dim cDelete As VbMsgBoxResult
Dim cNum As Integer
Dim DataSH As Worksheet
Set DataSH = Sheet1
Dim x As Integer
'error statement
On Error GoTo errHandler:
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
'check for values
' File Number or Date Received or Last Name
If Will2.Value = "" And Will4.Value = "" And Will5.Value = "" Then
MsgBox "There is no data to delete"
Exit Sub
End If
'give the user a chance to change their mind
cDelete = MsgBox("Are you sure that you want to delete this file?", _
vbYesNo + vbDefaultButton2, "Are you sure????")
If cDelete = vbYes Then
'find the row
Set findvalue = DataSH.Range("B:B").Find(What:=Me.Will1.Value, _
LookIn:=xlValues, LookAt:=xlWhole)
'delete the entire row
findvalue.EntireRow.Delete
End If
'clear the controls per field
'cNum = 7
cNum = 21
For x = 1 To cNum
'Me.Controls("Emp" & x).Value = ""
Me.Controls("Will" & x).Value = ""
Next
'unprotect all sheets for the advanced filter
'Unprotect_All
'filter the data
DataSH.Range("B8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Data!$AA$8:$AA$9"), CopyToRange:=Range("Data!$AC$8:$AW$8"), _
Unique:=False
'if no data exists then clear the rowsource
If DataSH.Range("AA9").Value = "" Then
lstWill.RowSource = ""
Else
'add the filtered data to the rowsource
lstWill.RowSource = DataSH.Range("outdata").Address(external:=True)
End If
'sort the data by "LastName"
DataSH.Select
With DataSH
.Range("B9:V10000").Sort Key1:=Range("F9"), Order1:=xlAscending, Header:=xlGuess
End With
'Protect all sheets
'Protect_All
'return to sheet
Sheet2.Select
'error block
On Error GoTo 0
Exit Sub
errHandler:
'Protect all sheets if error occurs
'Protect_All
'show error information in a messagebox
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " & _
Err.Number & vbCrLf & Err.Description & vbCrLf & "Please notify the administrator"
End Sub
Private Sub cmdEdit_Click()
'declare the variables
Dim findvalue As Range
Dim cNum As Integer
Dim DataSH As Worksheet
'error handling
On Error GoTo errHandler:
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
Set DataSH = Sheet1
'check for values
If Will1.Value = "" Or Will2.Value = "" Or Will5.Value = "" Then
MsgBox "There is no data to edit"
Exit Sub
End If
'clear the listbox
lstWill.RowSource = ""
'find the row to edit
Set findvalue = DataSH.Range("B:B"). _
Find(What:=Me.Will1.Value, LookIn:=xlValues, LookAt:=xlWhole)
'update the values
findvalue = Will1.Value
findvalue.Offset(0, 1) = Will2.Value
findvalue.Offset(0, 2) = Will3.Value
findvalue.Offset(0, 3) = Will4.Value
findvalue.Offset(0, 4) = Will5.Value
findvalue.Offset(0, 5) = Will6.Value
findvalue.Offset(0, 6) = Will7.Value
findvalue.Offset(0, 7) = Will8.Value
findvalue.Offset(0, 8) = Will9.Value
findvalue.Offset(0, 9) = Will10.Value
findvalue.Offset(0, 10) = Will11.Value
findvalue.Offset(0, 11) = Will12.Value
findvalue.Offset(0, 12) = Will13.Value
findvalue.Offset(0, 13) = Will14.Value
findvalue.Offset(0, 14) = Will15.Value
findvalue.Offset(0, 15) = Will16.Value
findvalue.Offset(0, 16) = Will17.Value
findvalue.Offset(0, 17) = Will18.Value
findvalue.Offset(0, 18) = Will19.Value
findvalue.Offset(0, 19) = Will20.Value
findvalue.Offset(0, 20) = Will21.Value
'unprotect the worksheets for the advanced filter
'Unprotect_All
'filter the data
DataSH.Range("B8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Data!$AA$8:$AA$9"), CopyToRange:=Range("Data!$AC$8:$AW$8"), _
Unique:=False
'if no data exists then clear the rowsource
If DataSH.Range("AG9").Value = "" Then
lstWill.RowSource = ""
Else
'add the filtered data to the rowsource
lstWill.RowSource = DataSH.Range("outdata").Address(external:=True)
End If
'return to sheet
Sheet2.Select
'Protect all sheets
'Protect_All
'error block
On Error GoTo 0
Exit Sub
errHandler:
'Protect all sheets
'Protect_All
'show error information in a messagebox
MsgBox "An Error has Occurred " & vbCrLf & _
"The error number is: " & Err.Number & vbCrLf & _
Err.Description & vbCrLf & "Please notify the administrator"
End Sub
Private Sub lstWill_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'dim the variables
Dim i As Integer
On Error Resume Next
'find the selected list item
i = Me.lstWill.ListIndex
'add the values to the text boxes
Me.Will1.Value = Me.lstWill.Column(0, i)
Me.Will2.Value = Me.lstWill.Column(1, i)
Me.Will3.Value = Me.lstWill.Column(2, i)
Me.Will4.Value = Me.lstWill.Column(3, i)
Me.Will5.Value = Me.lstWill.Column(4, i)
Me.Will6.Value = Me.lstWill.Column(5, i)
Me.Will7.Value = Me.lstWill.Column(6, i)
Me.Will8.Value = Me.lstWill.Column(7, i)
Me.Will9.Value = Me.lstWill.Column(8, i)
Me.Will10.Value = Me.lstWill.Column(9, i)
Me.Will11.Value = Me.lstWill.Column(10, i)
Me.Will12.Value = Me.lstWill.Column(11, i)
Me.Will13.Value = Me.lstWill.Column(12, i)
Me.Will14.Value = Me.lstWill.Column(13, i)
Me.Will15.Value = Me.lstWill.Column(14, i)
Me.Will16.Value = Me.lstWill.Column(15, i)
Me.Will17.Value = Me.lstWill.Column(16, i)
Me.Will18.Value = Me.lstWill.Column(17, i)
Me.Will19.Value = Me.lstWill.Column(18, i)
Me.Will20.Value = Me.lstWill.Column(19, i)
Me.Will21.Value = Me.lstWill.Column(20, i)
On Error GoTo 0
End Sub
Private Sub txtDateReceived_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If txtDateReceived = vbEmptyString Then Exit Sub
If IsDate(txtDateReceived) Then
txtDateReceived = Format(txtDateReceived, "mm/dd/yyyy")
Else
MsgBox "Please enter a valid date mm/dd/yyyy", vbCritical
End If
End Sub
Private Sub txtFileNumber_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Trim(txtFileNumber.Value) = "" And Me.Visible Then
MsgBox "Field Required YYSPFileNumber example 19SP1234", vbCritical, "Error"
Cancel = True
txtFileNumber.BackColor = vbYellow
Else
txtFileNumber.BackColor = vbWhite
End If
End Sub
Private Sub txtLastName_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Trim(txtLastName.Value) = "" And Me.Visible Then
MsgBox "Last Name Required", vbCritical, "Error"
Cancel = True
txtLastName.BackColor = vbYellow
Else
txtLastName.BackColor = vbWhite
End If
End Sub
Private Sub txtSearch_Change()
'dim the variables
Dim Crit As Range
Dim FindMe As Range
Dim DataSH As Worksheet
'error handler
On Error GoTo errHandler:
'set object variables
Set DataSH = Sheet1
'hold in memory and stop screen flicker
Application.ScreenUpdating = False
'///////////////////////////////////////////
'if header is selected add the criteria
If Me.cboHeader.Value <> "All_Columns" Then
If Me.txtSearch = "" Then
DataSH.Range("AA9") = ""
Else
DataSH.Range("AA9") = "*" & Me.txtSearch.Value & "*"
End If
End If
'//////////////////////////////////////////
'if all columns is selected
If Me.cboHeader.Value = "All_Columns" Then
'find the value in the column
Set FindMe = DataSH.Range("B9:V10000").Find(What:=txtSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'variable for criteria header
Set Crit = DataSH.Cells(8, FindMe.Column)
'if no criteria is added to the search
If Me.txtSearch = "" Then
DataSH.Range("AA9") = ""
DataSH.Range("AA8") = ""
Else
'add values from the search
DataSH.Range("AA8") = Crit
If Crit = "ID" Then
DataSH.Range("AA9") = Me.txtSearch.Value
Else
DataSH.Range("AA9") = "*" & Me.txtSearch.Value & "*"
End If
'show in the userform the header that is added
Me.txtAllColumn = DataSH.Range("AA8").Value
End If
End If
'/////////////////////////////////////////
'unprotect all sheets
'Unprotect_All
'filter the data
DataSH.Range("B8").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("Data!$AA$8:$AA$9"), CopyToRange:=Range("Data!$AC$8:$AW$8"), _
Unique:=False
'add the dynamic data to the listbox
lstWill.RowSource = DataSH.Range("outdata").Address(external:=True)
'protect all sheets
'Protect_All
'error handler
On Error GoTo 0
Exit Sub
errHandler:
'Protect all sheets
'Protect_All
'if error occurs then show me exactly where the error occurs
MsgBox "No match found for " & txtSearch.Text
'clear the listbox if no match is found
Me.lstWill.RowSource = ""
Exit Sub
End Sub
Private Sub txtDateTxfr_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If txtDateTxfr = vbEmptyString Then Exit Sub
If IsDate(txtDateTxfr) Then
txtDateTxfr = Format(txtDateTxfr, "mm/dd/yyyy")
Else
MsgBox "Please enter a valid date mm/dd/yyyy", vbCritical
End If
End Sub
Private Sub txtDateRemoved_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If txtDateRemoved = vbEmptyString Then Exit Sub
If IsDate(txtDateRemoved) Then
txtDateTxfr = Format(txtDateRemoved, "mm/dd/yyyy")
Else
MsgBox "Please enter a valid date mm/dd/yyyy", vbCritical
End If
End Sub
Private Sub txtZipCode_DropButt*******()
Dim i As Long, LastRFow As Long
LastRow = Sheets("CountyZipCode").Range("A" & rws.Count).End(x1up).Row
If Me.txtZipCode.ListCount = 0 Then
For i = 2 To LastRow
Me.txtZipCode.AddItem Sheets("CountyZipCode").Cells(i, "A").Value
Next i
End If
End Sub
Private Sub txtZipCode_Change()
Dim i As Long, LastRow As Long
LastRow = Sheets("CountyZipCode").Range("A" & Rows.Count).End(x1up).Row
For i = 2 To LastRow
'If Sheets("CountyZipCode").Cells(i, "A").Value = (Me.txtZipCode) Or _
'Sheets("CountyZipCode").Cells(i, "A").Value = Val(Me.txtZipCode) Then
Me.txtCity = Sheets("CountyZipCode").Cells(i, "B").Value
Me.txtState = Sheets("CountyZipCode").Cells(i, "C").Value
' End If
Next
End Sub
Private Sub txtZipCode2_Change()
End Sub
Private Sub Will4_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Will4 = vbEmptyString Then Exit Sub
If IsDate(Will4) Then
txtDateTxfr = Format(Will4, "mm/dd/yyyy")
Else
MsgBox "Please enter a valid date mm/dd/yyyy", vbCritical
End If
End Sub
Private Sub Will17_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Will17 = vbEmptyString Then Exit Sub
If IsDate(Will17) Then
txtDateTxfr = Format(Will17, "mm/dd/yyyy")
Else
MsgBox "Please enter a valid date mm/dd/yyyy", vbCritical
End If
End Sub
Private Sub Will18_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Will18 = vbEmptyString Then Exit Sub
If IsDate(Will18) Then
txtDateTxfr = Format(Will18, "mm/dd/yyyy")
Else
MsgBox "Please enter a valid date mm/dd/yyyy", vbCritical
End If
End Sub
' Private Sub txtFileNumber_Exit(ByVal Cancel As MSForms.ReturnBoolean)
' If txtFileNumber = vbEmptyString Then Exit Sub
' If IsDate(txtFileNumber) Then
' txtFileNumber = Format(txtFileNumber, "##SP####0")
' Else
' MsgBox "Please enter a valid File Number as 2 - digit Year "YY" plus "SP" plus 5 - digit file number 0001, example 20SP12345", vbCritical
' End If
' End Sub
' Private Sub FileNumber Format()
' ActiveSheet.Columns("C").NumberFormat = "##SP#####"
Sub Auto_Open()
'Activate a Sheet
Sheets("Home").Activate
'Show an UserForm
UserForm1.Show
End Sub
Last edited by a moderator:
